[CSM-258] Fix error message on paper vend redemption

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletAddress
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       , mkCWalletSetAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error $ "Invalid mnemonic: mnemonic should have exactly " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletSetAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> CT.CWalletMeta
mkCWalletMeta wName =
    CT.CWalletMeta { cwName: wName
                   }

mkCWalletAddress :: String -> CT.CWalletAddress
mkCWalletAddress = CWalletAddress

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wName
                   }

mkCWalletSetAssurance :: String -> CT.CWalletSetAssurance
mkCWalletSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletSetInit :: String -> String -> Int -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta:
                                CWalletSetMeta
                                    { cwsName: wSetName
                                    , cwsAssurance: mkCWalletSetAssurance wsAssurance
                                    , cwsUnit: wsUnit
                                    }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCWalletAddress
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       , mkCWalletSetAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have exactly 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletSetAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> CT.CWalletMeta
mkCWalletMeta wName =
    CT.CWalletMeta { cwName: wName
                   }

mkCWalletAddress :: String -> CT.CWalletAddress
mkCWalletAddress = CWalletAddress

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wName
                   }

mkCWalletSetAssurance :: String -> CT.CWalletSetAssurance
mkCWalletSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletSetInit :: String -> String -> Int -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta:
                                CWalletSetMeta
                                    { cwsName: wSetName
                                    , cwsAssurance: mkCWalletSetAssurance wsAssurance
                                    , cwsUnit: wsUnit
                                    }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale


Add unlabeled versions to `Run.Writer`

Add unlabeled versions to `Run.Writer`

Similar reasoning as before.
Alternates without labels give power to the users.

module Run.Writer
  ( Writer(..)
  , WRITER
  , _writer
  , liftWriter
  , liftWriterAt
  , tell
  , tellAt
  , censor
  , censorAt
  , foldWriter
  , foldWriterAt
  , runWriter
  , runWriterAt
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Monoid (class Monoid, mempty)
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..))
import Run (Run, SProxy(..), FProxy)
import Run as Run

data Writer w a = Writer w a

derive instance functorWriter ∷ Functor (Writer w)

type WRITER w = FProxy (Writer w)

_writer ∷ SProxy "writer"
_writer = SProxy

liftWriter ∷ ∀ w a r. Writer w a → Run (writer ∷ WRITER w | r) a
liftWriter = liftWriterAt _writer

liftWriterAt ∷
  ∀ w a r t s
  . IsSymbol s
  ⇒ RowCons s (WRITER w) t r
  ⇒ SProxy s
  → Writer w a
  → Run r a
liftWriterAt = Run.lift

tell ∷ ∀ w r. w → Run (writer ∷ WRITER w | r) Unit
tell = tellAt _writer

tellAt ∷
  ∀ w r t s
  . IsSymbol s
  ⇒ RowCons s (WRITER w) t r
  ⇒ SProxy s
  → w
  → Run r Unit
tellAt sym w = liftWriterAt sym (Writer w unit)

censor ∷ ∀ w a r. (w → w) → Run (writer ∷ WRITER w | r) a → Run (writer ∷ WRITER w | r) a
censor = censorAt _writer

censorAt ∷
  ∀ w a r t s
  . IsSymbol s
  ⇒ RowCons s (WRITER w) t r
  ⇒ SProxy s
  → (w → w)
  → Run r a
  → Run r a
censorAt sym = loop
  where
  handle = Run.on sym Left Right
  loop f r = case Run.peel r of
    Left a → case handle a of
      Left (Writer w n) → do
        tellAt sym (f w)
        censorAt sym f n
      Right _ →
        Run.send a >>= censorAt sym f
    Right a →
      pure a

foldWriter ∷ ∀ w b a r. (b → w → b) → b → Run (writer ∷ WRITER w | r) a → Run r (Tuple b a)
foldWriter = foldWriterAt _writer

foldWriterAt ∷
  ∀ w b a r t s
  . IsSymbol s
  ⇒ RowCons s (WRITER w) t r
  ⇒ SProxy s
  → (b → w → b)
  → b
  → Run r a
  → Run t (Tuple b a)
foldWriterAt sym = loop
  where
  handle = Run.on sym Left Right
  loop k w r = case Run.peel r of
    Left a → case handle a of
      Left (Writer w' n) →
        loop k (k w w') n
      Right a' →
        Run.send a' >>= foldWriterAt sym k w
    Right a →
      pure (Tuple w a)

runWriter ∷ ∀ w a r. Monoid w ⇒ Run (writer ∷ WRITER w | r) a → Run r (Tuple w a)
runWriter = runWriterAt _writer

runWriterAt ∷
  ∀ w a r t s
  . IsSymbol s
  ⇒ Monoid w
  ⇒ RowCons s (WRITER w) t r
  ⇒ SProxy s
  → Run r a
  → Run t (Tuple w a)
runWriterAt sym = foldWriterAt sym (<>) mempty

module Run.Writer
  ( Writer(..)
  , WRITER
  , _writer
  , liftWriter
  , tell
  , censor
  , foldWriter
  , runWriter
  ) where

import Prelude
import Data.Either (Either(..))
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(..))
import Run (Run, SProxy(..), FProxy)
import Run as Run

data Writer w a = Writer w a

derive instance functorWriter ∷ Functor (Writer w)

type WRITER w = FProxy (Writer w)

_writer ∷ SProxy "writer"
_writer = SProxy

liftWriter ∷ ∀ w a r. Writer w a → Run (writer ∷ WRITER w | r) a
liftWriter = Run.lift _writer

tell ∷ ∀ w r. w → Run (writer ∷ WRITER w | r) Unit
tell w = liftWriter (Writer w unit)

censor ∷ ∀ w a r. (w → w) → Run (writer ∷ WRITER w | r) a → Run (writer ∷ WRITER w | r) a
censor = loop
  where
  handle = Run.on _writer Left Right
  loop f r = case Run.peel r of
    Left a → case handle a of
      Left (Writer w n) → do
        tell (f w)
        censor f n
      Right _ →
        Run.send a >>= censor f
    Right a →
      pure a

foldWriter ∷ ∀ w b a r. (b → w → b) → b → Run (writer ∷ WRITER w | r) a → Run r (Tuple b a)
foldWriter = loop
  where
  handle = Run.on _writer Left Right
  loop k w r = case Run.peel r of
    Left a → case handle a of
      Left (Writer w' n) →
        loop k (k w w') n
      Right a' →
        Run.send a' >>= foldWriter k w
    Right a →
      pure (Tuple w a)

runWriter ∷ ∀ w a r. Monoid w ⇒ Run (writer ∷ WRITER w | r) a → Run r (Tuple w a)
runWriter = foldWriter (<>) mempty


Samples now pass

Samples now pass

Original commit 9e91d75fb1b87f1b9f170bb2cb786c2cfca89c8e

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import { Convert } from "./quicktype";
//     let value = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import { Convert } from "./quicktype";
//     let value = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Test for hacked authtoken in Aff

Test for hacked authtoken in Aff

module Test.Authentication (authenticationSpec) where

import Prelude (Unit, bind, ($), map, show)

import Control.Monad.Aff (launchAff, attempt)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Authentication.Eff (authWithCustomToken)
import Web.Firebase.Authentication.Aff as AuthAff

authenticationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR, console :: CONSOLE | eff ) Unit
authenticationSpec forbiddenRef = do
    describe "Authentication" do
      describe "with Eff" do
        it "on fake authentication token calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ authWithCustomToken
                                 "imaginarytoken"
                                 (\_   -> launchAff $ putVar respVar "unexpected sucess")
                                 (\err -> launchAff $ putVar respVar (show err))
                                 forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "INVALID_TOKEN: Could not parse auth token.\n | firebase code: | \n INVALID_TOKEN"
      describe "with Aff" do
        it "on fake authentication throws an error" do
          expectError $ AuthAff.authWithCustomToken "faketoken" forbiddenRef

module Test.Authentication (authenticationSpec) where

import Prelude (Unit, bind, ($), map, show)

import Control.Monad.Aff (launchAff, attempt)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)
import Web.Firebase.Authentication.Eff (authWithCustomToken)

authenticationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR, console :: CONSOLE | eff ) Unit
authenticationSpec forbiddenRef = do
    describe "Authentication" do
      describe "with Eff" do
        it "on fake authentication token calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ authWithCustomToken
                                 "imaginarytoken"
                                 (\_   -> launchAff $ putVar respVar "unexpected sucess")
                                 (\err -> launchAff $ putVar respVar (show err))
                                 forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "INVALID_TOKEN: Could not parse auth token.\n | firebase code: | \n INVALID_TOKEN"


Update for new Prelude

Update for new Prelude

module QuickCheck where

import Prelude
import Eff
import Random
import Arrays
import Trace

data Result = Success | Failed String

class Arb t where
  arb :: forall eff. Eff (random :: Random | eff) t

instance Arb Number where
  arb = random

instance Arb Boolean where
  arb = do
    n <- random
    return ((n * 2) < 1)

instance (Arb a) => Arb [a] where
  arb = do
    b <- arb
    if b then return [] else do
      a <- arb
      as <- arb
      return (a : as)

class Testable prop where
  test :: forall eff. prop -> Eff (random :: Random | eff) Result

instance Testable Result where
  test = return

instance Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance (Show t, Arb t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arb
    result <- test (f t)
    case result of
      Success -> return Success
      Failed msg -> return $ Failed $ "Failed on input " ++ show t ++ ": \n" ++ msg

quickCheck' :: forall prop eff. (Testable prop) => Number -> prop -> Eff (random :: Random, trace :: Trace | eff) {}
quickCheck' 0 _ = trace "All tests passed"
quickCheck' n prop = do
  result <- test prop
  case result of
    Success -> quickCheck' (n - 1) prop
    Failed msg -> trace $ "Test failed: \n" ++ msg

quickCheck :: forall prop eff. (Testable prop) => prop -> Eff (random :: Random, trace :: Trace | eff) {}
quickCheck prop = quickCheck' 100 prop

module QuickCheck where

import Prelude
import Eff
import Random
import Arrays
import Trace

data Result = Success | Failed String

class Arb t where
  arb :: forall eff. Eff (random :: Random | eff) t

instance Arb Number where
  arb = random

instance Arb Boolean where
  arb = do
    n <- random
    ret ((n * 2) < 1)

instance (Arb a) => Arb [a] where
  arb = do
    b <- arb
    if b then ret [] else do
      a <- arb
      as <- arb
      ret (a : as)

class Testable prop where
  test :: forall eff. prop -> Eff (random :: Random | eff) Result

instance Testable Result where
  test = ret

instance Testable Boolean where
  test true = ret Success
  test false = ret $ Failed "Test returned false"

instance (Show t, Arb t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arb
    result <- test (f t)
    case result of
      Success -> ret Success
      Failed msg -> ret $ Failed $ "Failed on input " ++ show t ++ ": \n" ++ msg

quickCheck' :: forall prop eff. (Testable prop) => Number -> prop -> Eff (random :: Random, trace :: Trace | eff) {}
quickCheck' 0 _ = trace "All tests passed"
quickCheck' n prop = do
  result <- test prop
  case result of
    Success -> quickCheck' (n - 1) prop
    Failed msg -> trace $ "Test failed: \n" ++ msg

quickCheck :: forall prop eff. (Testable prop) => prop -> Eff (random :: Random, trace :: Trace | eff) {}
quickCheck prop = quickCheck' 100 prop


A small refactoring.

A small refactoring.

module Types.Attendee
  (Attendee(..)
  , visualizeAttendee
  , AttendeeDB
  , newAttendeeDB
  , getAttendeeById
  , getAttendeeByNumber
  , insertAttendee
  , listAttendees
  ) where

import Data.Array as A
import Data.Foldable (foldr)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype)
import Data.String (Pattern(..), split)
import Data.Tuple (Tuple(..))
import Prelude (class Eq, map, ($), (<#>), (<>), (>>=), (>>>))
import Record (modify)
import Simple.JSON (class ReadForeign, readImpl)
import Type.Prelude (SProxy(..))

newtype Attendee = Attendee
  { id      :: Int
  , cid     :: String
  , name    :: String
  , nick    :: Maybe String
  , numbers :: Array Int
  }
derive instance eqAt :: Eq      Attendee
derive instance ntAt :: Newtype Attendee _

instance rfAt :: ReadForeign Attendee where
  readImpl fr =
    readImpl fr
      <#> modify
          (SProxy :: SProxy "numbers")
          go
      >>> Attendee
    where
      go :: Array { id :: Int } -> Array Int
      go = map \{id} -> id

visualizeAttendee :: Attendee -> String
visualizeAttendee (Attendee a) =
  fromMaybe
    a.name
    (a.nick
      >>= \nick -> A.uncons (split (Pattern " ") a.name)
      <#> \{head, tail} -> A.intercalate " " ([head, "”" <> nick <> "”"] <> tail))

newtype AttendeeDB = AttendeeDB
  { idToAttendee :: M.Map Int Attendee
  , numberToId   :: M.Map Int Int
  }

newAttendeeDB :: Array Attendee -> AttendeeDB
newAttendeeDB as = AttendeeDB
  { idToAttendee : M.fromFoldable (map (\a@(Attendee a') -> Tuple a'.id a) as)
  , numberToId   : M.fromFoldable (foldr (\(Attendee a) acc -> acc <> map (\n -> Tuple n a.id) a.numbers) mempty as)
  }

getAttendeeById :: Int -> AttendeeDB -> Maybe Attendee
getAttendeeById i (AttendeeDB a) = M.lookup i a.idToAttendee

getAttendeeByNumber :: Int -> AttendeeDB -> Maybe Attendee
getAttendeeByNumber i a@(AttendeeDB a') =
  M.lookup i a'.numberToId >>= (\i' -> getAttendeeById i' a)

insertAttendee :: Attendee -> AttendeeDB -> AttendeeDB
insertAttendee a@(Attendee a') (AttendeeDB db) = AttendeeDB $
  db { idToAttendee = M.insert a'.id a db.idToAttendee
     , numberToId   = foldr (\n acc -> M.insert n a'.id acc) db.numberToId a'.numbers
     }

listAttendees :: AttendeeDB -> L.List Attendee
listAttendees (AttendeeDB {idToAttendee}) = M.values idToAttendee

module Types.Attendee
  (Attendee(..)
  , visualizeAttendee
  , AttendeeDB
  , newAttendeeDB
  , getAttendeeById
  , getAttendeeByNumber
  , insertAttendee
  , listAttendees
  ) where

import Data.Array as A
import Data.Foldable (foldr)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Newtype (class Newtype)
import Data.String (Pattern(..), split)
import Data.Tuple (Tuple(..))
import Prelude (class Eq, map, ($), (<#>), (<>), (>>=), (>>>))
import Record (modify)
import Simple.JSON (class ReadForeign, readImpl)
import Type.Prelude (SProxy(..))

newtype Attendee = Attendee
  { id      :: Int
  , cid     :: String
  , name    :: String
  , nick    :: Maybe String
  , numbers :: Array Int
  }
derive instance eqAt :: Eq      Attendee
derive instance ntAt :: Newtype Attendee _

instance rfAt :: ReadForeign Attendee where
  readImpl fr =
    readImpl fr
      <#> modify
          (SProxy :: SProxy "numbers")
          go
      >>> Attendee
    where
      go :: Array { id :: Int } -> Array Int
      go = map \{id} -> id

visualizeAttendee :: Attendee -> String
visualizeAttendee (Attendee a) =
  case a.nick of
    Nothing -> a.name
    Just n  ->
      case A.uncons (split (Pattern " ") a.name) of
        Nothing           -> a.name
        Just {head, tail} -> A.intercalate " " ([head] <> ["”" <> n <> "”"] <> tail)

newtype AttendeeDB = AttendeeDB
  { idToAttendee :: M.Map Int Attendee
  , numberToId   :: M.Map Int Int
  }

newAttendeeDB :: Array Attendee -> AttendeeDB
newAttendeeDB as = AttendeeDB
  { idToAttendee : M.fromFoldable (map (\a@(Attendee a') -> Tuple a'.id a) as)
  , numberToId   : M.fromFoldable (foldr (\(Attendee a) acc -> acc <> map (\n -> Tuple n a.id) a.numbers) mempty as)
  }

getAttendeeById :: Int -> AttendeeDB -> Maybe Attendee
getAttendeeById i (AttendeeDB a) = M.lookup i a.idToAttendee

getAttendeeByNumber :: Int -> AttendeeDB -> Maybe Attendee
getAttendeeByNumber i a@(AttendeeDB a') =
  M.lookup i a'.numberToId >>= (\i' -> getAttendeeById i' a)

insertAttendee :: Attendee -> AttendeeDB -> AttendeeDB
insertAttendee a@(Attendee a') (AttendeeDB db) = AttendeeDB $
  db { idToAttendee = M.insert a'.id a db.idToAttendee
     , numberToId   = foldr (\n acc -> M.insert n a'.id acc) db.numberToId a'.numbers
     }

listAttendees :: AttendeeDB -> L.List Attendee
listAttendees (AttendeeDB {idToAttendee}) = M.values idToAttendee


Reordered Evaluator tests.

Reordered Evaluator tests.

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

import Test.Utils (Test, tell, padLeft)

tell' :: String -> Test Unit
tell' = tell

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_13" prelude "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalEnvTest "arithmetic_sequences_14" prelude "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalEnvTest "arithmetic_sequences_15" prelude "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalEnvTest "arithmetic_sequences_16" prelude "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalEnvTest "arithmetic_sequences_17" prelude "[2147483647 ..]" "[2147483647]"
  evalEnvTest "arithmetic_sequences_18" prelude "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalEnvTest "arithmetic_sequences_19" prelude "[-2147483648]" "[-2147483648]"
  evalEnvTest "arithmetic_sequences_20" prelude "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalEnvTest "list_comprehension_1" prelude "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalEnvTest "list_comprehension_2" prelude "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalEnvTest "list_comprehension_3" prelude "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalEnvTest "list_comprehension_4" prelude "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalEnvTest "list_comprehension_5" prelude "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalEnvTest "list_comprehension_6" prelude "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalEnvTest "list_comprehension_7" prelude "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalEnvTest "list_comprehension_8" prelude "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalEnvTest "list_comprehension_9" prelude "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalEnvTest "list_comprehension_10" prelude "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalEnvTest "let_expression_1" prelude "let x = 1; x = 'c' in x" "'c'"
  evalEnvTest "let_expression_2" prelude "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalEnvTest "let_expression_3" prelude "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalEnvTest "let_expression_4" prelude "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalEnvTest "let_expression_5" prelude "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalEnvTest "let_expression_6" prelude "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"

  testsADT

testsADT :: Test Unit
testsADT = do
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"

  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw)
  = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)
  = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)
  = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk (\_ ho hor -> ho + hor) (\_ h -> h) max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed
  = (> 0)
  . foldBauwerk
    (\br _ br' -> if br' < 0 || br' > br then -1 else br)
    (\br _ -> br)
    (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

module Test.Evaluator where

import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
-- import Data.List (List, singleton)

-- import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression, runParserIndent)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

import Test.Utils (Test, tell, padLeft)

tell' :: String -> Test Unit
tell' = tell

eval1test :: String -> String -> String -> Test Unit
eval1test name input expected = case (Tuple (runParserIndent expression input) (runParserIndent expression expected)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" ++ name ++ ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

eval1EnvTest :: String -> String -> String -> String -> Test Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then pure unit -- log $ "Eval success (" <> name <> ")"
          else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show eval1Exp) <> "\n"
            <> "Expected:\n"
            <> padLeft (show expExp)
      (Left err) -> tell'
        $ "Eval fail (" <> name <> "):\n"
        <> padLeft (show err)
  _ -> tell' $ "Parse fail (" <> name <> ")"

evalEnvTest :: String -> String -> String -> String -> Test Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParserIndent expression input) (runParserIndent expression expected)) (runParserIndent definitions env)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then pure unit -- log $ "Eval success (" ++ name ++ ")"
        else tell'
             $ "Eval fail (" <> name <> "):\n"
            <> "Input String:\n"
            <> padLeft input <> "\n"
            <> "Input Parsed:\n"
            <> padLeft (show inExp) <> "\n"
            <> "Output:\n"
            <> padLeft (show evalExp) <> "\n"
            <> "Expected String:\n"
            <> padLeft expected <> "\n"
            <> "Expected Parsed:\n"
            <> padLeft (show expExp) <> "\n"
            <> "Definitions String:\n"
            <> padLeft env <> "\n"
            <> "Definitions Parsed:\n"
            <> padLeft (show defs)
  (Tuple (Tuple pi pe) pd) -> tell'
     $ "Parse fail (" <> name <> "):\n"
    <> "Input:\n"
    <> padLeft (show pi) <> "\n"
    <> "Expected:\n"
    <> padLeft (show pe) <> "\n"
    <> "Definitions:\n"
    <> padLeft (show pd)

envPdP1 :: String
envPdP1 = """
foldBauwerk fRechteck fSpitze fSplit (Rechteck br ho bw) = fRechteck br ho (foldBauwerk fRechteck fSpitze fSplit bw)
foldBauwerk fRechteck fSpitze fSplit (Spitze br ho)      = fSpitze br ho
foldBauwerk fRechteck fSpitze fSplit (Split l r)         = fSplit (foldBauwerk fRechteck fSpitze fSplit l) (foldBauwerk fRechteck fSpitze fSplit r)

numParts (Rechteck _ _ bw) = 1 + numParts bw
numParts (Spitze _ _) = 1
numParts (Split l r)  = numParts l + numParts r

max a b = if a < b then b else a

maxHoehe = foldBauwerk (\_ ho hor -> ho + hor) (\_ h -> h) max

numPeaks = foldBauwerk (\_ _ ps -> ps) (\_ _ -> 1) (+)

wellformed = (> 0) . foldBauwerk (\br _ br' -> if br' < 0 || br' > br then -1 else br) (\br _ -> br) (\l r -> l + r)
"""

bspPdP1 :: String
bspPdP1 = """(Rechteck 50 20
  (Split
    (Rechteck 20 15
      (Split
        (Rechteck 10 20
          (Rechteck 8 18
            (Spitze 8 14)))
        (Rechteck 8 17
          (Spitze 8 14))))
    (Rechteck 20 15
      (Split
        (Rechteck 8 17
          (Spitze 8 14))
        (Rechteck 10 20
          (Split
            (Spitze 5 17)
            (Spitze 5 17)))))))
"""

runTests :: Test Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "7 * 5"
  eval1test "section2" "(10<) 8" "10 < 8"
  eval1test "prefix" "(&&) True True" "True && True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  -- ADT-stuff
  eval1test "constr-1"
    "1 :+ 1"
    "1 :+ 1"
  eval1test "constr-2"
    "Foo"
    "Foo"
  eval1test "constr-3"
    "Foo 1"
    "Foo 1"
  eval1test "constr-4"
    "Foo 1 2"
    "Foo 1 2"

  eval1test "constr-5"
    "if True then Foo else Bar"
    "Foo"

  eval1test "constr-6"
    "if False then Foo else Bar"
    "Bar"

  eval1EnvTest "func-1"
    "foo (Foo x) = x"
    "foo (Foo 1)"
    "1"

  eval1EnvTest "func-2"
    "foo (Foo x y) = x + y"
    "foo (Foo 1 2)"
    "1 + 2"

  eval1EnvTest "map-func-3"
    "map f Nil = Nil\nmap f (Cons x xs) = Cons (f x) (map f xs)"
    "map (1 +) (Cons 1 (Cons 2 (Cons 3 Nil)))"
    "Cons ((1 +) 1) (map (1 +) (Cons 2 (Cons 3 Nil)))"

  eval1EnvTest "map-func-4"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) Nil"
    "Nil"

  eval1EnvTest "map-func-5"
    "map f Nil = Nil\nmap f (x::xs) = f x :: map f xs"
    "map (^2) (1 :: (2 :: (3 :: Nil)))"
    "(^2) 1 :: map (^2) (2 :: (3 :: Nil))"

  eval1EnvTest "tuple-1"
    "fst (Tuple a _) = a\n"
    "fst (Tuple (Tuple 1 2) 3)"
    "Tuple 1 2"

  eval1EnvTest "tuple-2"
    "snd (Tuple _ a) = a\n"
    "snd (Tuple (Tuple 1 2) 3)"
    "3"

  eval1EnvTest "infix-1"
    "fst (a ::: _) = a"
    "fst (1 ::: 3)"
    "1"

  eval1EnvTest "infix-2"
    "snd (_ ::: a) = a"
    "snd (1 ::: 3)"
    "3"

  evalEnvTest "infix-3"
    "map f g (a :-: b) = f a :-: g b\ndouble = map (*2) (*2)"
    "double (2 :-: 3)"
    "4 :-: 6"

  evalEnvTest "prefix-1"
    "map f g (Tuple x y) = Tuple (f x) (g y)\ndouble = map (*2) (*2)"
    "double (Tuple 2 3)"
    "Tuple 4 6"

  evalEnvTest "constr-nested-1"
    "foo (Bar (Bar a) Foo) = Foo a a"
    "foo (Bar (Bar Foo) Foo)"
    "Foo Foo Foo"

  evalEnvTest "pdp1-a" envPdP1
    ("numParts " <> bspPdP1)
    "13"

  evalEnvTest "pdp1-b" envPdP1
    ("foldBauwerk Rechteck Spitze Split " <> bspPdP1)
    bspPdP1

  evalEnvTest "pdp1-c" envPdP1
    ("maxHoehe " <> bspPdP1)
    "87"

  evalEnvTest "pdp1-d" envPdP1
    ("numPeaks " <> bspPdP1)
    "5"

  evalEnvTest "pdp1-e" envPdP1
    ("wellformed " <> bspPdP1)
    "True"
  ------------

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude <> "\n" <>
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" <>
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude <> "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude <> "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude <> "\n" <>
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" <>
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"
  evalEnvTest "arithmetic_sequences_13" prelude "[1 .. 10]" "[1,2,3,4,5,6,7,8,9,10]"
  evalEnvTest "arithmetic_sequences_14" prelude "[5, 9 .. 20]" "[5, 9, 13, 17]"
  evalEnvTest "arithmetic_sequences_15" prelude "take 5 [3, -1 ..]" "[3, -1, -5, -9, -13]"
  evalEnvTest "arithmetic_sequences_16" prelude "take 11 [-5 ..]" "[-5, -4, -3, -2, -1, 0, 1, 2 ,3, 4, 5]"
  evalEnvTest "arithmetic_sequences_17" prelude "[2147483647 ..]" "[2147483647]"
  evalEnvTest "arithmetic_sequences_18" prelude "[2147483644, 2147483646 ..]" "[2147483644, 2147483646]"
  evalEnvTest "arithmetic_sequences_19" prelude "[-2147483648]" "[-2147483648]"
  evalEnvTest "arithmetic_sequences_20" prelude "[-2147483645, -2147483647 ..]" "[-2147483645, -2147483647]"

  evalEnvTest "list_comprehension_1" prelude "[ x | x <- [1 .. 10], even x]" "[2, 4, 6, 8, 10]"
  evalEnvTest "list_comprehension_2" prelude "[ (x, y) | x <- [1 .. 3], y <- [1 .. 3], x + y == 4]" "[(1,3), (2,2), (3,1)]"
  evalEnvTest "list_comprehension_3" prelude "(\\x -> [ x | let x = 1]) 2"    "[1]"
  evalEnvTest "list_comprehension_4" prelude "[ x | let x = 1, True, let x = 'a']" "['a']"
  evalEnvTest "list_comprehension_5" prelude "[ y | y <- [1 .. 10], y < y]"  "[]"
  evalEnvTest "list_comprehension_6" prelude "[ [ y | y <- reverse x] | x <- [[1 .. 10]]]" "[[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]]"
  evalEnvTest "list_comprehension_7" prelude "[ x | x <- [1 .. 5], y <- [x .. 5]]" "[1,1,1,1,1, 2,2,2,2, 3,3,3, 4,4, 5]"
  evalEnvTest "list_comprehension_8" prelude "[x | x <- \"wer misst zu viele gabeln\", elem x \"itzgw\"]" "\"witzig\""
  evalEnvTest "list_comprehension_9" prelude "[(x, z) | x <- [1 .. 5], z <- [y | y <- [1 .. 5], mod x y == 0] ]" "[(1,1), (2,1), (2,2), (3,1), (3,3), (4,1), (4,2), (4,4), (5,1), (5,5)]"
  evalEnvTest "list_comprehension_10" prelude "[z | let y = [True, True, False], z <- y, z]" "[True, True]"

  --should fail, due to overlapping defs
  --evalEnvTest "let_expression_1" prelude "let x = 1; x = 'c' in x" "'c'"
  evalEnvTest "let_expression_2" prelude "let (x, y) = (\\g -> g, \"Hello\") in x y" "\"Hello\""
  evalEnvTest "let_expression_3" prelude "let x = 1 ; y = x + 1; z = y + 1 in x + y + z" "6"
  evalEnvTest "let_expression_4" prelude "let x = 1 in let y = 2 in x + y" "3"
  --                                                                                should be: "True"
  evalEnvTest "let_expression_5" prelude "(let x = [1,2,3] in x) == (let x = 1; y = 2; z = 3 in [x,y,z])" "[1,2,3] == [1,2,3]"
  evalEnvTest "let_expression_6" prelude "let sum = \\x -> x ; y = sum [1,2,3] in y" "[1,2,3]"