Remove unneeded type error

Remove unneeded type error

module AST where

import Prelude (class Show, class Eq, class Ord, show, (<>))
import Data.List (List)
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.
data Expr = Atom Atom
          | List (List Expr)
          | NTuple (List Expr)
          | Binary Op Expr Expr
          | Unary Op Expr
          | SectL Expr Op
          | SectR Op Expr
          | PrefixOp Op
          | IfExpr Expr Expr Expr
          | ArithmSeq Expr (Maybe Expr) (Maybe Expr)
          | LetExpr (List (Tuple Binding Expr)) Expr
          | Lambda (List Binding) Expr
          | App Expr (List Expr)
          | ListComp Expr (List (ExprQual))

data Qual b e = Gen b e | Let b e | Guard e

data QualTree b e t =
    TGen b e t
  | TLet b e t
  | TGuard e t

type ExprQual = Qual Binding Expr

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)
data TypeTree
          = TAtom                                   Type
          | TListTree (List TypeTree)               Type
          | TNTuple (List TypeTree)                 Type
          | TBinary Type TypeTree TypeTree          Type
          | TUnary Type TypeTree                    Type
          | TSectL TypeTree Type                    Type
          | TSectR Type TypeTree                    Type
          | TPrefixOp                               Type
          | TIfExpr TypeTree TypeTree TypeTree      Type
          | TArithmSeq TypeTree (Maybe TypeTree) (Maybe TypeTree) Type
          | TLetExpr (List (Tuple TypeBinding TypeTree)) TypeTree  Type
          | TLambda (List TypeBinding) TypeTree     Type
          | TApp TypeTree (List TypeTree)           Type
          | TListComp TypeTree (List TypeQual) Type

type TypeQual  = QualTree TypeBinding TypeTree Type

data IndexTree
          = IAtom                                  Int
          | IListTree (List IndexTree)             Int
          | INTuple (List IndexTree)               Int
          | IBinary Int  IndexTree IndexTree           Int
          | IUnary Int IndexTree                      Int
          | ISectL IndexTree Int                      Int
          | ISectR Int IndexTree                      Int
          | IPrefixOp                              Int
          | IIfExpr IndexTree IndexTree IndexTree  Int
          | IArithmSeq IndexTree (Maybe IndexTree) (Maybe IndexTree) Int
          | ILetExpr (List (Tuple IBinding IndexTree)) IndexTree  Int
          | ILambda (List IBinding) IndexTree      Int
          | IApp IndexTree (List IndexTree)        Int
          | IListComp IndexTree (List IndexQual) Int

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
              | IConsLit IBinding IBinding  Int
              | IListLit (List IBinding)    Int
              | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqExpr :: Eq Expr

derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

data Path = Nth Int Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " <> show i <> " " <> show p <>")"
    Fst   p -> "(Fst " <> show p <>")"
    Snd   p -> "(Snd " <> show p <>")"
    Thrd   p -> "(Thrd " <> show p <>")"
    End     -> "End"

derive instance eqDefinition :: Eq Definition

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "<>"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQual :: (Show b, Show e) => Show (Qual b e) where
  show q = case q of
    Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
    Let b e -> "Let (" <> show b <> " " <> show e <> ")"
    Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (TGen a b c) = "TGen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TLet a b c) = "TLet (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TGuard a c)  = "TGuard (" <> show a <> " " <> show c <> ")"

instance showExpr :: Show Expr where
  show expr = case expr of
    Atom atom       -> "Atom (" <> show atom <> ")"
    List ls         -> "List (" <> show ls <> ")"
    NTuple ls       -> "NTuple (" <> show ls <> ")"
    Binary op e1 e2 -> "Binary " <> show op <> " (" <> show e1 <> ") (" <> show e2 <> ")"
    Unary op e      -> "Unary " <> show op <> " (" <> show e <> ")"
    SectL expr op   -> "SectL (" <> show expr <> ") " <> show op
    SectR op expr   -> "SectR " <> show op <> " (" <> show expr <> ")"
    PrefixOp op     -> "PrefixOp " <> show op
    IfExpr ce te ee  -> "IfExpr (" <> show ce <> ") (" <> show te <> ") (" <> show ee <> ")"
    ArithmSeq s by e -> "ArithmSeq (" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr b e   -> "LetExpr (" <> show b <> ") (" <> show e <> ")"
    Lambda binds body -> "Lambda (" <> show binds <> ") (" <> show body <> ")"
    App func args   -> "App (" <> show func <> ") (" <> show args <> ")"
    ListComp expr quals -> "ListComp (" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

instance showTypeTree :: Show TypeTree where
  show (TAtom t) = "(TAtom " <> show t <> ")"
  show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
  show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
  show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
  show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
  show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
  show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
  show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
  show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
  show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
  show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
  show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
  show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
  show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

extractType:: TypeTree -> Type
extractType (TAtom t)            = t
extractType (TListTree _ t)      = t
extractType (TNTuple _ t)        = t
extractType (TBinary _ _ _ t)    = t
extractType (TUnary _ _ t)       = t
extractType (TSectL _ _ t)       = t
extractType (TSectR _ _ t)       = t
extractType (TPrefixOp t)        = t
extractType (TIfExpr _ _ _ t)    = t
extractType (TArithmSeq _ _ _ t) = t
extractType (TLetExpr _ _ t)     = t
extractType (TLambda _ _ t)      = t
extractType (TApp _ _ t)         = t
extractType (TListComp _ _ t)    = t

extractIndex :: IndexTree -> Int
extractIndex (IAtom i)            = i
extractIndex (IListTree _ i)      = i
extractIndex (INTuple _ i)        = i
extractIndex (IBinary _ _ _ i)    = i
extractIndex (IUnary _ _ i)       = i
extractIndex (ISectL _ _ i)       = i
extractIndex (ISectR _ _ i)       = i
extractIndex (IPrefixOp i)        = i
extractIndex (IIfExpr _ _ _ i)    = i
extractIndex (IArithmSeq _ _ _ i) = i
extractIndex (ILetExpr _ _ i)     = i
extractIndex (ILambda _ _ i)      = i
extractIndex (IApp _ _ i)         = i
extractIndex (IListComp _ _ i)    = i

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t

module AST where

import Prelude (class Show, class Eq, class Ord, show, (<>))
import Data.List (List)
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.
data Expr = Atom Atom
          | List (List Expr)
          | NTuple (List Expr)
          | Binary Op Expr Expr
          | Unary Op Expr
          | SectL Expr Op
          | SectR Op Expr
          | PrefixOp Op
          | IfExpr Expr Expr Expr
          | ArithmSeq Expr (Maybe Expr) (Maybe Expr)
          | LetExpr (List (Tuple Binding Expr)) Expr
          | Lambda (List Binding) Expr
          | App Expr (List Expr)
          | ListComp Expr (List (ExprQual))

data Qual b e = Gen b e | Let b e | Guard e

data QualTree b e t =
    TGen b e t
  | TLet b e t
  | TGuard e t

type ExprQual = Qual Binding Expr

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)
data TypeTree
          = TAtom                                   Type
          | TListTree (List TypeTree)               Type
          | TNTuple (List TypeTree)                 Type
          | TBinary Type TypeTree TypeTree          Type
          | TUnary Type TypeTree                    Type
          | TSectL TypeTree Type                    Type
          | TSectR Type TypeTree                    Type
          | TPrefixOp                               Type
          | TIfExpr TypeTree TypeTree TypeTree      Type
          | TArithmSeq TypeTree (Maybe TypeTree) (Maybe TypeTree) Type
          | TLetExpr (List (Tuple TypeBinding TypeTree)) TypeTree  Type
          | TLambda (List TypeBinding) TypeTree     Type
          | TApp TypeTree (List TypeTree)           Type
          | TListComp TypeTree (List TypeQual) Type

type TypeQual  = QualTree TypeBinding TypeTree Type

data IndexTree
          = IAtom                                  Int
          | IListTree (List IndexTree)             Int
          | INTuple (List IndexTree)               Int
          | IBinary Int  IndexTree IndexTree           Int
          | IUnary Int IndexTree                      Int
          | ISectL IndexTree Int                      Int
          | ISectR Int IndexTree                      Int
          | IPrefixOp                              Int
          | IIfExpr IndexTree IndexTree IndexTree  Int
          | IArithmSeq IndexTree (Maybe IndexTree) (Maybe IndexTree) Int
          | ILetExpr (List (Tuple IBinding IndexTree)) IndexTree  Int
          | ILambda (List IBinding) IndexTree      Int
          | IApp IndexTree (List IndexTree)        Int
          | IListComp IndexTree (List IndexQual) Int

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
              | IConsLit IBinding IBinding  Int
              | IListLit (List IBinding)    Int
              | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnificationMismatch (List Type) (List Type)
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqExpr :: Eq Expr

derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

data Path = Nth Int Path
          | Fst Path
          | Snd Path
          | Thrd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " <> show i <> " " <> show p <>")"
    Fst   p -> "(Fst " <> show p <>")"
    Snd   p -> "(Snd " <> show p <>")"
    Thrd   p -> "(Thrd " <> show p <>")"
    End     -> "End"

derive instance eqDefinition :: Eq Definition

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "<>"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQual :: (Show b, Show e) => Show (Qual b e) where
  show q = case q of
    Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
    Let b e -> "Let (" <> show b <> " " <> show e <> ")"
    Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (TGen a b c) = "TGen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TLet a b c) = "TLet (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TGuard a c)  = "TGuard (" <> show a <> " " <> show c <> ")"

instance showExpr :: Show Expr where
  show expr = case expr of
    Atom atom       -> "Atom (" <> show atom <> ")"
    List ls         -> "List (" <> show ls <> ")"
    NTuple ls       -> "NTuple (" <> show ls <> ")"
    Binary op e1 e2 -> "Binary " <> show op <> " (" <> show e1 <> ") (" <> show e2 <> ")"
    Unary op e      -> "Unary " <> show op <> " (" <> show e <> ")"
    SectL expr op   -> "SectL (" <> show expr <> ") " <> show op
    SectR op expr   -> "SectR " <> show op <> " (" <> show expr <> ")"
    PrefixOp op     -> "PrefixOp " <> show op
    IfExpr ce te ee  -> "IfExpr (" <> show ce <> ") (" <> show te <> ") (" <> show ee <> ")"
    ArithmSeq s by e -> "ArithmSeq (" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr b e   -> "LetExpr (" <> show b <> ") (" <> show e <> ")"
    Lambda binds body -> "Lambda (" <> show binds <> ") (" <> show body <> ")"
    App func args   -> "App (" <> show func <> ") (" <> show args <> ")"
    ListComp expr quals -> "ListComp (" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnificationMismatch a b) = "(UnificationMismatch " <> show a <> " " <> show b <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

instance showTypeTree :: Show TypeTree where
  show (TAtom t) = "(TAtom " <> show t <> ")"
  show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
  show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
  show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
  show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
  show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
  show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
  show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
  show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
  show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
  show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
  show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
  show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
  show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

extractType:: TypeTree -> Type
extractType (TAtom t)            = t
extractType (TListTree _ t)      = t
extractType (TNTuple _ t)        = t
extractType (TBinary _ _ _ t)    = t
extractType (TUnary _ _ t)       = t
extractType (TSectL _ _ t)       = t
extractType (TSectR _ _ t)       = t
extractType (TPrefixOp t)        = t
extractType (TIfExpr _ _ _ t)    = t
extractType (TArithmSeq _ _ _ t) = t
extractType (TLetExpr _ _ t)     = t
extractType (TLambda _ _ t)      = t
extractType (TApp _ _ t)         = t
extractType (TListComp _ _ t)    = t

extractIndex :: IndexTree -> Int
extractIndex (IAtom i)            = i
extractIndex (IListTree _ i)      = i
extractIndex (INTuple _ i)        = i
extractIndex (IBinary _ _ _ i)    = i
extractIndex (IUnary _ _ i)       = i
extractIndex (ISectL _ _ i)       = i
extractIndex (ISectR _ _ i)       = i
extractIndex (IPrefixOp i)        = i
extractIndex (IIfExpr _ _ _ i)    = i
extractIndex (IArithmSeq _ _ _ i) = i
extractIndex (ILetExpr _ _ i)     = i
extractIndex (ILambda _ _ i)      = i
extractIndex (IApp _ _ i)         = i
extractIndex (IListComp _ _ i)    = i

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t


add documentation to IDBFactory

add documentation to IDBFactory

-- | Database objects are accessed through methods on the IDBFactory interface.
-- | A single object implementing this interface is present in the global scope
-- | of environments that support Indexed DB operations.
module Database.IndexedDB.IDBFactory where

import Prelude                 (Unit)

import Control.Monad.Aff       (Aff)
import Control.Monad.Eff       (Eff)
import Data.Function.Uncurried  as Fn
import Data.Function.Uncurried (Fn4)
import Data.Maybe              (Maybe, fromMaybe)

import Database.IndexedDB.Core

--------------------
-- INTERFACE
--
-- Type alias for binding listeners to an initial open action
type OpenRequest e =
  { onBlocked       :: Maybe (Eff (| e) Unit)
  , onUpgradeNeeded :: Maybe (Database -> Transaction -> Eff (| e) Unit)
  }

-- | Type alias for DatabaseName
type DatabaseName = String

-- | Type alias for Version
type Version = Int

-- | Attempts to delete the named database. If the database already exists
-- | and there are open connections that don’t close in response to a
-- | `versionchange` event, the request will be blocked until all they close.
deleteDatabase
    :: forall e
    .  DatabaseName
    -> Aff (idb :: IDB | e) Int
deleteDatabase =
  _deleteDatabase

-- | Attempts to open a connection to the named database with the specified version.
-- | If the database already exists with a lower version and there are open connections
-- | that don’t close in response to a versionchange event, the request will be blocked
-- | until all they close, then an upgrade will occur. If the database already exists with
-- | a higher version the request will fail.
-- |
-- | When the version isn't provided (`Nothing`), attempts to open a connection to the
-- | named database with the current version, or 1 if it does not already exist.
open
    :: forall e e'
    .  DatabaseName
    -> Maybe Version
    -> OpenRequest e'
    -> Aff (idb :: IDB | e) Database
open name mver req =
  Fn.runFn4 _open fromMaybe name mver req

--------------------
-- FFI
--
foreign import _deleteDatabase
    :: forall e
    .  String
    -> Aff (idb :: IDB | e) Int

foreign import _open
    :: forall a e e'
    .  Fn4 (a -> Maybe a -> a) String (Maybe Int) (OpenRequest e') (Aff (idb :: IDB | e) Database)

module Database.IndexedDB.IDBFactory where

import Prelude                     (Unit)

import Control.Monad.Aff           (Aff)
import Control.Monad.Eff           (Eff)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn4)
import Data.Maybe                  (Maybe, fromMaybe)

import Database.IndexedDB.Core

--------------------
-- INTERFACE
--
type OpenRequest e =
  { onBlocked       :: Maybe (Eff (| e) Unit)
  , onUpgradeNeeded :: Maybe (Database -> Transaction -> Eff (| e) Unit)
  }

deleteDatabase :: forall e. String -> Aff (idb :: IDB | e) Int
deleteDatabase =
  _deleteDatabase

open :: forall e e'.  String -> Maybe Int -> OpenRequest e' -> Aff (idb :: IDB | e) Database
open name mver req =
  Fn.runFn4 _open fromMaybe name mver req

--------------------
-- FFI
--
foreign import _deleteDatabase :: forall e. String -> Aff (idb :: IDB | e) Int

foreign import _open :: forall a e e'. Fn4 (a -> Maybe a -> a) String (Maybe Int) (OpenRequest e') (Aff (idb :: IDB | e) Database)


Implementing various class types

Implementing various class types

module Gauge where

import Prelude
import Data.Maybe
import Data.Monoid (class Monoid, mempty)
import Data.Array
import Data.Tuple (Tuple(..))
import Data.Time (Time)
import Data.Map as Map
import Data.Map (Map)

import Pux.Html.Events (onClick)
import Pux.Html as H
--import Pux.CSS as CSS
import Pux.Html.Events as E

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate

derive instance viewTypeEq :: Eq ViewType

data Action = UpdateStats (Array NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: Array NodeStats }

-- /todo: Add Node = String | IPAddress
newtype BStats = BStats Int
instance bstatsSemigroup :: Semigroup BStats where
    append (BStats b1) (BStats b2 ) = BStats (b1 + b2)
instance bstatsMonoid :: Monoid BStats where
    mempty = BStats 0
instance bstatsShow :: Show BStats where
    show (BStats b) = show b

type Node = String

newtype Broker = Broker { name :: Node, port :: Int }

derive instance brokerEq :: Eq Broker
derive instance brokerOrd :: Ord Broker

instance brokerShow :: Show Broker where
    show (Broker {name,port}) = show name <> ":" <> show port
-- instance brokerOrd :: Ord Broker where
--     compare (Broker {name:n1, port:p1}) (Broker {name:n2, port:p2}) = (compare n1 n2) <> (compare p1 p2)

type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: Array BrokerStats}

init :: State
init = { viewType : PerBroker, stats : [] }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (Array NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # numConnections >>> show

viewAs :: ViewType -> (Array NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    (s # map \{node,brokers} ->
        let agg = brokers # map _.connections >>> fold in
        H.div []
            [ H.h1  [] [H.text $ show node]
            , viewStats agg ])

viewAs PerBroker s =
    let
        mergeBrokerStats m {broker, connections} = addOrInsert connections broker m
        statsPerBroker = s # concatMap _.brokers
                           >>> foldl mergeBrokerStats Map.empty
                           >>> Map.toAscUnfoldable
    in
    H.div []
    (statsPerBroker # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [H.text $ show broker]
            , viewStats agg])

viewAs PerNodeAndBroker s =
    H.div [] $
    s # concatMap (\{node,brokers} -> brokers # map \brokerStats -> {node,brokerStats})
    >>> (map \{node,brokerStats} ->
        H.div []
        [ H.h1  [] [H.text $ "Node: " <> node <> " Broker: " <> show brokerStats.broker]
            , viewStats brokerStats.connections])

viewAs Aggregate s =
    let agg = numConnections s in
    H.div []
        [ H.h1  [] [H.text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [H.text "Connections:"]
        , H.p  [] [H.text $ show stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.ul []
     (optionView viewType <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView sel v =
    H.li
        (if v == sel then [] else [E.onClick $ const (ChangeView v)])
        [H.text $ show v]

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

numConnections :: Array NodeStats -> BStats
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> fold

upsert :: forall k v. (Monoid v, Ord k) => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

updateJust f = emptyIfNothing >>> f >>> Just

addOrInsert :: forall k v. (Monoid v, Ord k) => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty

module Gauge where

import Prelude
import Control.Bind ((=<<))
import Control.Monad.Eff.Exception
import Data.Maybe
import Data.Monoid
import Data.Functor
import Data.List as L
import Data.Map as Map
import Data.Eq (Eq)
import Data.Foldable (sum)
import Data.List (concatMap)
import Data.Map (Map, alter, fromFoldable, update)

import Pux.Html.Events (onClick)
import Pux.Html as H
import Pux.CSS as CSS
import Pux.Html.Attributes as A
import Pux.Html.Events as E

import React.DOM.Props (onChange)

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate deriving Eq

data Action = UpdateStats (List NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: List NodeStats }

-- /todo: Add Node = String | IPAddress
type BStats = Int
type Node = String

type Broker =
    { name :: Node
    , port :: Int }
type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: List BrokerStats}

init :: State
init = { viewType : PerBroker, stats : Nil }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (List NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # show <<< numConnections

viewAs :: ViewType -> (List NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    s # map \{node,brokers} ->
        let agg = brokers # map _.connections # sum in
        H.div []
            [ H.h1  [] [text $ show node]
            , viewStats agg ]

viewAs PerBroker s =
    let mergeBrokerStats {broker, connections} = addOrInsert broker connections
        statsPerBroker = s # concatMap _.brokers
                            >>> foldl mergeBrokerStats Map.empty
                            >>> Map.toAscUnfoldable
    in
    H.div []
    statsPerBroker
    # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [text $ show broker]
            , viewStats agg]

viewAs PerNodeAndBroker s =
    H.div []
    s # concatMap \{node,brokers} -> brokers # map {node,brokerStats}
    >>> map \{node,brokerStats} ->
        [ H.h1  [] [text $ "Node: " <> node <> " Broker: " <> show brokerStats.broker]
            , viewStats brokerStats.connections]

viewAs Aggregate s =
    let agg = s # numConnections in
    H.div []
        [ H.h1  [] [text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [text "Connections:"]
        , H.p  [] [text $ show stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.ul []
     (optionView viewType <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView sel v =
    H.li
        if v == sel
        then [CSS.style ""]
        else [E.onClick $ const (ChangeView v)]
        [H.text $ show v]

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

numConnections :: List NodeStats -> Int
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> sum

upsert :: forall k v. Monoid v => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

addOrInsert :: forall k v. Monoid v => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<#>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty


Fix indentation

Fix indentation

module Web
  ( exprToJQuery
  , Handler ()
  ) where

import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import DOM

import Data.Traversable (for)
import Data.Maybe

import AST
import Evaluator

type Handler = forall eff. Expr -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\_ _ -> evaluate p expr handler) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

evaluate :: forall eff. Path -> Expr -> Handler -> Eff (dom :: DOM | eff) Unit
evaluate p expr handler = case evalPath1 Data.StrMap.empty p expr of
  Nothing    -> return unit
  Just expr' -> handler expr'


Nuke `setInnerHtml` in favor of simple-dom

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module DomHelpers where

import Control.Monad.Eff
import Data.DOM.Simple.Types

foreign import setOnclick
  "function setOnclick(ele) {\
  \  return function(f) {\
  \    return function() {\
  \      ele.onclick = f;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff a. HTMLElement -> (a -> Unit) -> Eff eff Unit

foreign import setDisplayFn
  "function setDisplayFn(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      return function() {\
  \        ele.style.display = s;\
  \        return;\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff (Unit -> Unit)

foreign import setDisplay
  "function setDisplay(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      ele.style.display = s;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff Unit

foreign import setClass
  "function setClass(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      ele.className = s;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff (Unit -> Unit)

module DomHelpers where

import Control.Monad.Eff
import Data.DOM.Simple.Types

foreign import setOnclick
  "function setOnclick(ele) {\
  \  return function(f) {\
  \    return function() {\
  \      ele.onclick = f;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff a. HTMLElement -> (a -> Unit) -> Eff eff Unit

foreign import setDisplayFn
  "function setDisplayFn(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      return function() {\
  \        ele.style.display = s;\
  \        return;\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff (Unit -> Unit)

foreign import setDisplay
  "function setDisplay(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      ele.style.display = s;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff Unit

foreign import setInnerHtml
  "function setInnerHtml(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      ele.innerHTML = s;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff (Unit -> Unit)

foreign import setClass
  "function setClass(ele) {\
  \  return function(s) {\
  \    return function() {\
  \      ele.className = s;\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. HTMLElement -> String -> Eff eff (Unit -> Unit)


Better messages if benchmark functions throw exceptions

module Benchotron
  ( Benchmark()
  , BenchmarkFunction()
  , benchFn
  , benchFn'
  , runBenchmark
  , benchmarkToFile
  , benchmarkToStdout
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  , Stats()
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception(), Error(), catchException,
                                    throwException, message, error)
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

-- | A value representing a benchmark to be performed. The type parameter 'e'
-- | is provided to allow you to supply a random value generator with arbitrary
-- | effects, if you need to. The type parameter 'a' is the type of the input
-- | to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: An Eff action which should produce a random input of the given
-- |   argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type Benchmark e a =
  { title              :: String
  , sizes              :: Array Number
  , sizeInterpretation :: String
  , inputsPerSize      :: Number
  , gen                :: Number -> Eff (BenchEffects e) a
  , functions          :: Array (BenchmarkFunction a)
  }

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) BenchmarkResult
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [ "Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs   <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
                  let name = getName function
                  handleBenchmarkException name size $ do
                    stats <- runBenchmarkFunction inputs function
                    return { name: name, stats: stats }

    return { size: size, allStats: allStats }

  stderrWrite "\n"
  let series = rejig results
  return
    { title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

-- TODO: use purescript-exceptions instead. This appears to be blocked on:
--    https://github.com/purescript/purescript-exceptions/issues/5
foreign import handleBenchmarkException
  """
  function handleBenchmarkException(name) {
    return function(size) {
      return function(innerAction) {
        return function() {
          try {
            return innerAction()
          } catch(innerError) {
            throw new Error(
              'While running Benchotron benchmark function: ' + name + ' ' +
                'at n=' + String(size) + ':\n' +
                innerError.name + ': ' + innerError.message)
          }
        }
      }
    }
  }
  """ :: forall e a. String -> Number -> Eff (BenchEffects e) a -> Eff (BenchEffects e) a

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results
  stderrWrite $ "Benchmark \""<> bench.title <> "\" results written to " <> path <> "\n"

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type BenchmarkResult =
  { title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Number
  , stats :: Stats
  }

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

foreign import data BenchmarkJS :: *
foreign import benchmarkJS "var benchmarkJS = require('benchmark')" :: BenchmarkJS

-- this is (unfortunately) necessary to stop Benchmark from trying to decompile
-- your functions to Strings, and then using 'eval' in the tests. I'm not quite
-- sure why it does this, but it breaks things, due to imported modules no
-- longer being in scope :(
--
-- Here, we monkey-patch the Benchmark object to fool the library into thinking
-- function decompilation is not supported, which should hopefully stop this
-- from happening.
foreign import monkeyPatchBenchmark
  """
  function monkeyPatchBenchmark(b) {
    return function() {
      b.support.decompilation = false;
    }
  }
  """ :: forall e. BenchmarkJS -> Eff (BenchEffects e) Unit

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(Benchmark) {
    return function(fn) {
      return function() {
        var b = new Benchmark(fn)
        b.run()
        if (typeof b.error !== 'undefined') {
           throw b.error
        }
        return b.stats
      }
    }
  }
  """ :: forall e. BenchmarkJS -> (Unit -> Any) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: BenchmarkResult -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

module Benchotron
  ( Benchmark()
  , BenchmarkFunction()
  , benchFn
  , benchFn'
  , runBenchmark
  , benchmarkToFile
  , benchmarkToStdout
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  , Stats()
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception())
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

-- | A value representing a benchmark to be performed. The type parameter 'e'
-- | is provided to allow you to supply a random value generator with arbitrary
-- | effects, if you need to. The type parameter 'a' is the type of the input
-- | to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: An Eff action which should produce a random input of the given
-- |   argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type Benchmark e a =
  { title              :: String
  , sizes              :: Array Number
  , sizeInterpretation :: String
  , inputsPerSize      :: Number
  , gen                :: Number -> Eff (BenchEffects e) a
  , functions          :: Array (BenchmarkFunction a)
  }

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) BenchmarkResult
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [ "Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs   <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
                  stats <- runBenchmarkFunction inputs function
                  return { name: getName function, stats: stats }

    return { size: size, allStats: allStats }

  stderrWrite "\n"
  let series = rejig results
  return
    { title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results
  stderrWrite $ "Benchmark \""<> bench.title <> "\" results written to " <> path <> "\n"

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type BenchmarkResult =
  { title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Number
  , stats :: Stats
  }

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

foreign import data BenchmarkJS :: *
foreign import benchmarkJS "var benchmarkJS = require('benchmark')" :: BenchmarkJS

-- this is (unfortunately) necessary to stop Benchmark from trying to decompile
-- your functions to Strings, and then using 'eval' in the tests. I'm not quite
-- sure why it does this, but it breaks things, due to imported modules no
-- longer being in scope :(
--
-- Here, we monkey-patch the Benchmark object to fool the library into thinking
-- function decompilation is not supported, which should hopefully stop this
-- from happening.
foreign import monkeyPatchBenchmark
  """
  function monkeyPatchBenchmark(b) {
    return function() {
      b.support.decompilation = false;
    }
  }
  """ :: forall e. BenchmarkJS -> Eff (BenchEffects e) Unit

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(Benchmark) {
    return function(fn) {
      return function() {
        var b = new Benchmark(fn)
        b.run()
        if (typeof b.error !== 'undefined') {
           throw b.error
        }
        return b.stats
      }
    }
  }
  """ :: forall e. BenchmarkJS -> (Unit -> Any) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: BenchmarkResult -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit


Added flag image from state

Added flag image from state

module Flag.App (Event, Country(..), init, foldp, view) where

import CSS.Transform (offset)
import Data.Array (length, uncons)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String

newtype Country = Country { name :: String, flag :: String }
derive instance newtypeCountry :: Newtype Country _
instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = noEffects state { correct = state.correct + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = { state: state { correct = 0, incorrect = 0 }, effects: [ do
  pure $ Just(ReceiveCountries $ Tuple
    [Country { name: "Ecuador", flag: "ecuador.svg" }]
    ["Ecuador", "Slovenia", "Aruba", "Indonesia"]
  )
] }

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."

module Flag.App (Event, Country(..), init, foldp, view) where

import Data.Array (length)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Data.Tuple (Tuple(..))
import Prelude hiding (div)
import Data.Traversable (for_)

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String

newtype Country = Country { name :: String, flag :: String }
derive instance newtypeCountry :: Newtype Country _
instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = noEffects state { correct = state.correct + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = { state: state { correct = 0, incorrect = 0 }, effects: [ do
  pure $ Just(ReceiveCountries $ Tuple
    [Country { name: "Russia", flag: "russia.svg" }]
    ["Ecuador", "Slovenia", "Aruba", "Indonesia"]
  )
] }

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section do
    img ! src "/images/flags/indonesia.svg"
    ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name