Add missing Eq AD case

Add missing Eq AD case

module AST where

import Prelude (class Show, class Eq,class Ord, show, (++), (==), (&&),eq, compare,Ordering(..))
import Data.List (List)

-- | 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 | Div | Mod
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar

instance eqOp :: Eq Op where
  eq Composition Composition = true
  eq Power Power = true
  eq Mul  Mul  = true
  eq Div  Div  = true
  eq Mod Mod = true
  eq Add  Add  = true
  eq Sub Sub = true
  eq Colon  Colon  = true
  eq Append Append = true
  eq Equ  Equ  = true
  eq Neq  Neq  = true
  eq Lt  Lt  = true
  eq Leq  Leq  = true
  eq Gt  Gt  = true
  eq Geq Geq = true
  eq And And = true
  eq Or Or = true
  eq Dollar Dollar = true
  eq _ _ = false

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

instance eqAtom :: Eq Atom where
  eq (AInt i)   (AInt j) =  i == j
  eq (Bool b1) (Bool b2) = b1 == b2
  eq (Char s1) (Char s2) = s1 == s2
  eq (Name s1) (Name s2) = s1 == s2
  eq _ _ = false

instance ordAtom :: Ord Atom where
  compare (AInt a) (AInt b) = compare a b
  compare (Bool a) (Bool b) = compare a b
  compare (Char a) (Char b) = compare a b
  compare (Name a) (Name b) = compare a b
  compare _ _ = EQ

-- | 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
          | LetExpr Binding Expr Expr
          | Lambda (List Binding) Expr
          | App Expr (List 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
          | TLetExpr TypeBinding TypeTree TypeTree  Type
          | TLambda (List TypeBinding) TypeTree     Type
          | TApp TypeTree (List 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
          | ILetExpr IBinding IndexTree IndexTree  Int
          | ILambda (List IBinding) IndexTree      Int
          | IApp IndexTree (List 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

data TVar = 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

instance eqExpr :: Eq Expr where
  eq (Atom a1)           (Atom a2)         = a1 == a2
  eq (List l1)           (List l2)         = l1 == l2
  eq (NTuple l1)         (NTuple l2)       = l1 == l2
  eq (Binary o1 e1 e2)   (Binary o2 e3 e4) = o1 == o2 && e1 == e3 && e2 == e4
  eq (Unary o1 e1)       (Unary o2 e2)     = o1 == o2 && e1 == e2
  eq (SectL e1 o1)       (SectL e2 o2)     = e1 == e2 && o1 == o2
  eq (SectR o1 e1)       (SectR o2 e2)     = o1 == o2 && e1 == e2
  eq (PrefixOp o1)       (PrefixOp o2)     = o1 == o2
  eq (IfExpr c1 t1 e1)   (IfExpr c2 t2 e2) = c1 == c2 && t1 == t2 && e1 == e2
  eq (LetExpr a b c)     (LetExpr d e f)   = a == d && b == e && c == f
  eq (Lambda bs1 e1)     (Lambda bs2 e2)   = bs1 == bs2 && e1 == e2
  eq (App e1 l1)         (App e2 l2)       = e1 == e2 && l1 == l2
  eq _                   _                 = false

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

instance eqBinding :: Eq Binding where
  eq (Lit a1) (Lit a2) = a1 == a2
  eq (ConsLit b1 b2) (ConsLit b3 b4) = b1 == b3 && b2 == b4
  eq (ListLit l1) (ListLit l2) = l1 == l2
  eq (NTupleLit l1) (NTupleLit l2) = l1 == l2
  eq _ _ = false

-- | 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"

instance eqDefinition :: Eq Definition where
  eq (Def n1 b1 e1) (Def n2 b2 e2) = n1 == n2 && b1 == b2 && e1 == e2

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Div    -> "Div"
    Mod    -> "Mod"
    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"

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

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 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 ++ ")"
    LetExpr b l e   -> "LetExpr (" ++ show b ++ ") (" ++ show l ++ ") (" ++ show e ++ ")"
    Lambda binds body -> "Lambda (" ++ show binds ++ ") (" ++ show body ++ ")"
    App func args   -> "App (" ++ show func ++ ") (" ++ show args ++ ")"

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 ++")"

instance eqType :: Eq Type where
  eq (TypVar a) (TypVar b) = a == b
  eq (TypCon a) (TypCon b) = a == b
  eq (TypArr a b) (TypArr a' b') = (a == a') && (b == b')
  eq (AD a) (AD b) = eq a b
  eq (TypeError a) (TypeError b) = (a == b)
  eq _ _ = false

instance ordTVar :: Ord TVar where
  compare (TVar a) (TVar b) = compare a b

instance eqTVar :: Eq TVar where
  eq (TVar a) (TVar b) = a == b

instance showTVar :: Show TVar where
  show (TVar a) = "(TVar " ++ show a ++ ")"

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

instance eqAD :: Eq AD where
  eq (TList a) (TList b) = eq a b
  eq (TTuple a) (TTuple b) = eq a b
  eq _          _          = false

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 a) = "(UnknownError " ++ show a ++ ")"

instance eqTypeError :: Eq TypeError where
  eq (UnificationFail a b) (UnificationFail a' b') = (a == a') && (b == b')
  eq (InfiniteType a b) (InfiniteType a' b') = (a == a') && (b == b')
  eq (UnboundVariable a) (UnboundVariable a') = (a == a')
  eq (UnificationMismatch a b) (UnificationMismatch a' b') = (a == a') && (b == b')
  eq (UnknownError a) (UnknownError a') = (a == a')
  eq _ _ = false

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 (TLetExpr b tt1 tt2 t) = "(TLetExpr " ++ show b ++ " " ++ show tt1 ++ " " ++ show tt2 ++ " " ++ 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 ++ ")"

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 ++")"

module AST where

import Prelude (class Show, class Eq,class Ord, show, (++), (==), (&&),eq, compare,Ordering(..))
import Data.List (List)

-- | 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 | Div | Mod
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar

instance eqOp :: Eq Op where
  eq Composition Composition = true
  eq Power Power = true
  eq Mul  Mul  = true
  eq Div  Div  = true
  eq Mod Mod = true
  eq Add  Add  = true
  eq Sub Sub = true
  eq Colon  Colon  = true
  eq Append Append = true
  eq Equ  Equ  = true
  eq Neq  Neq  = true
  eq Lt  Lt  = true
  eq Leq  Leq  = true
  eq Gt  Gt  = true
  eq Geq Geq = true
  eq And And = true
  eq Or Or = true
  eq Dollar Dollar = true
  eq _ _ = false

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

instance eqAtom :: Eq Atom where
  eq (AInt i)   (AInt j) =  i == j
  eq (Bool b1) (Bool b2) = b1 == b2
  eq (Char s1) (Char s2) = s1 == s2
  eq (Name s1) (Name s2) = s1 == s2
  eq _ _ = false

instance ordAtom :: Ord Atom where
  compare (AInt a) (AInt b) = compare a b
  compare (Bool a) (Bool b) = compare a b
  compare (Char a) (Char b) = compare a b
  compare (Name a) (Name b) = compare a b
  compare _ _ = EQ

-- | 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
          | LetExpr Binding Expr Expr
          | Lambda (List Binding) Expr
          | App Expr (List 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
          | TLetExpr TypeBinding TypeTree TypeTree  Type
          | TLambda (List TypeBinding) TypeTree     Type
          | TApp TypeTree (List 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
          | ILetExpr IBinding IndexTree IndexTree  Int
          | ILambda (List IBinding) IndexTree      Int
          | IApp IndexTree (List 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

data TVar = 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

instance eqExpr :: Eq Expr where
  eq (Atom a1)           (Atom a2)         = a1 == a2
  eq (List l1)           (List l2)         = l1 == l2
  eq (NTuple l1)         (NTuple l2)       = l1 == l2
  eq (Binary o1 e1 e2)   (Binary o2 e3 e4) = o1 == o2 && e1 == e3 && e2 == e4
  eq (Unary o1 e1)       (Unary o2 e2)     = o1 == o2 && e1 == e2
  eq (SectL e1 o1)       (SectL e2 o2)     = e1 == e2 && o1 == o2
  eq (SectR o1 e1)       (SectR o2 e2)     = o1 == o2 && e1 == e2
  eq (PrefixOp o1)       (PrefixOp o2)     = o1 == o2
  eq (IfExpr c1 t1 e1)   (IfExpr c2 t2 e2) = c1 == c2 && t1 == t2 && e1 == e2
  eq (LetExpr a b c)     (LetExpr d e f)   = a == d && b == e && c == f
  eq (Lambda bs1 e1)     (Lambda bs2 e2)   = bs1 == bs2 && e1 == e2
  eq (App e1 l1)         (App e2 l2)       = e1 == e2 && l1 == l2
  eq _                   _                 = false

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

instance eqBinding :: Eq Binding where
  eq (Lit a1) (Lit a2) = a1 == a2
  eq (ConsLit b1 b2) (ConsLit b3 b4) = b1 == b3 && b2 == b4
  eq (ListLit l1) (ListLit l2) = l1 == l2
  eq (NTupleLit l1) (NTupleLit l2) = l1 == l2
  eq _ _ = false

-- | 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"

instance eqDefinition :: Eq Definition where
  eq (Def n1 b1 e1) (Def n2 b2 e2) = n1 == n2 && b1 == b2 && e1 == e2

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Div    -> "Div"
    Mod    -> "Mod"
    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"

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

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 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 ++ ")"
    LetExpr b l e   -> "LetExpr (" ++ show b ++ ") (" ++ show l ++ ") (" ++ show e ++ ")"
    Lambda binds body -> "Lambda (" ++ show binds ++ ") (" ++ show body ++ ")"
    App func args   -> "App (" ++ show func ++ ") (" ++ show args ++ ")"

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 ++")"

instance eqType :: Eq Type where
  eq (TypVar a) (TypVar b) = a == b
  eq (TypCon a) (TypCon b) = a == b
  eq (TypArr a b) (TypArr a' b') = (a == a') && (b == b')
  eq (AD a) (AD b) = eq a b
  eq (TypeError a) (TypeError b) = (a == b)
  eq _ _ = false

instance ordTVar :: Ord TVar where
  compare (TVar a) (TVar b) = compare a b

instance eqTVar :: Eq TVar where
  eq (TVar a) (TVar b) = a == b

instance showTVar :: Show TVar where
  show (TVar a) = "(TVar " ++ show a ++ ")"

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

instance eqAD :: Eq AD where
  eq (TList a) (TList b) = eq a b
  eq (TTuple a) (TTuple b) = eq a b

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 a) = "(UnknownError " ++ show a ++ ")"

instance eqTypeError :: Eq TypeError where
  eq (UnificationFail a b) (UnificationFail a' b') = (a == a') && (b == b')
  eq (InfiniteType a b) (InfiniteType a' b') = (a == a') && (b == b')
  eq (UnboundVariable a) (UnboundVariable a') = (a == a')
  eq (UnificationMismatch a b) (UnificationMismatch a' b') = (a == a') && (b == b')
  eq (UnknownError a) (UnknownError a') = (a == a')
  eq _ _ = false

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 (TLetExpr b tt1 tt2 t) = "(TLetExpr " ++ show b ++ " " ++ show tt1 ++ " " ++ show tt2 ++ " " ++ 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 ++ ")"

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 ++")"


Refactor adding of event listeners

Refactor adding of event listeners

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (readString)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff a = forall eff. Eff (dom :: DOM, trace :: Trace | eff) a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  showExpr env expr

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: forall eff. (J.JQuery -> Eff (dom :: DOM | eff) Unit) -> J.JQuery -> Eff (dom :: DOM | eff) Unit

showExpr :: forall eff. Env -> Expr -> DOMEff Unit
showExpr env expr = do
  outputContainer <- J.select "#output-container"
  J.clear outputContainer

  output <- J.create "

" >>= J.addClass "output"
  J.append output outputContainer

  jexpr <- exprToJQuery expr
  J.append jexpr output

  J.find ".binary, .app, .func" output >>= map (makeClickable env expr)
  J.find ".clickable" output >>= addMouseOverListener
  J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  return unit

makeClickable :: forall eff. Env -> Expr -> J.JQuery -> DOMEff Unit
makeClickable env expr jq = do
  path <- getPath jq
  case evalPath1 env path expr of
    Nothing -> return unit
    Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> DOMEff Unit
addMouseOverListener jq = void $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: forall eff. Env -> Path -> Expr -> DOMEff Unit
evalExpr env path expr =
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      showExpr env expr'

getValue :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) String
getValue j = do
  value <- J.getValue j
  case readString value of
    Right str -> return str

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (readString)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff a = forall eff. Eff (dom :: DOM, trace :: Trace | eff) a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  showExpr env expr

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: forall eff. (J.JQuery -> Eff (dom :: DOM | eff) Unit) -> J.JQuery -> Eff (dom :: DOM | eff) Unit

showExpr :: forall eff. Env -> Expr -> DOMEff Unit
showExpr env expr = do
  outputContainer <- J.select "#output-container"
  J.clear outputContainer

  output <- J.create "

" >>= J.addClass "output"
  J.append output outputContainer

  jexpr <- exprToJQuery expr
  J.append jexpr output

  J.find ".binary, .app, .func" output >>= map (makeClickable env expr)

  J.find ".clickable" output
    >>= J.on "mouseover" (\je j -> do
      J.stopImmediatePropagation je
      J.find ".mouseOver" output >>= J.removeClass "mouseOver"
      J.addClass "mouseOver" j)

  J.body
    >>= J.on "mouseover" (\_ _ -> J.find ".mouseOver" output >>= J.removeClass "mouseOver")
  return unit

makeClickable :: forall eff. Env -> Expr -> J.JQuery -> DOMEff Unit
makeClickable env expr jq = do
  path <- getPath jq
  case evalPath1 env path expr of
    Nothing -> return unit
    Just _  -> void $ J.addClass "clickable" jq

evalExpr :: forall eff. Env -> Path -> Expr -> DOMEff Unit
evalExpr env path expr =
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      showExpr env expr'

getValue :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) String
getValue j = do
  value <- J.getValue j
  case readString value of
    Right str -> return str


Make vue api simple.

Make vue api simple.

module Main where

import Control.Monad.Eff

main = vue
    {
        el: "#demo",
        dat: { message: "Hello Vue.js!" }
    }

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        new Vue(opt);\
    \    }\
    \}" :: forall e r. r -> Eff e {}

module Main where

import Control.Monad.Eff
import Debug.Trace

main = vue $ def { dat = { message: "Can you hear me?" } }

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        new Vue(opt);\
    \    }\
    \}" :: forall e. VueOpt -> Eff e {}

type VueOpt = { el :: String, dat :: { message :: String } }

def :: VueOpt
def = { el: "#demo" , dat: { message: "Hello Vue.js!" } }


no need to re-export

no need to re-export

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

  , nub
  , nubBy
  , union
  , union'
  , unionBy
  , unionBy'
  , delete
  , deleteBy

  , (\\), difference
  , difference'
  , intersect
  , intersect'
  , intersectBy
  , intersectBy'

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> Maybe (NonEmptyArray Int)
range x y = fromArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

union :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> NonEmptyArray a
union = unionBy (==)

union' :: forall a. Eq a => NonEmptyArray a -> Array a -> NonEmptyArray a
union' = unionBy' (==)

unionBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> NonEmptyArray a
unionBy eq xs = unionBy' eq xs <<< toArray

unionBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> NonEmptyArray a
unionBy' eq xs = unsafeFromArray <<< A.unionBy eq (toArray xs)

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

difference :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
difference xs = adaptAny $ difference' xs

difference' :: forall a. Eq a => NonEmptyArray a -> Array a -> Array a
difference' xs = A.difference $ toArray xs

intersect :: forall a . Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
intersect = intersectBy eq

intersect' :: forall a . Eq a => NonEmptyArray a -> Array a -> Array a
intersect' = intersectBy' eq

intersectBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> Array a
intersectBy eq xs = intersectBy' eq xs <<< toArray

intersectBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> Array a
intersectBy' eq xs = A.intersectBy eq (toArray xs)

infix 5 difference as \\

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

  , nub
  , nubBy
  , union
  , union'
  , unionBy
  , unionBy'
  , delete
  , deleteBy

  , (\\), difference
  , difference'
  , intersect
  , intersect'
  , intersectBy
  , intersectBy'

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> Maybe (NonEmptyArray Int)
range x y = fromArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

union :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> NonEmptyArray a
union = unionBy (==)

union' :: forall a. Eq a => NonEmptyArray a -> Array a -> NonEmptyArray a
union' = unionBy' (==)

unionBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> NonEmptyArray a
unionBy eq xs = unionBy' eq xs <<< toArray

unionBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> NonEmptyArray a
unionBy' eq xs = unsafeFromArray <<< A.unionBy eq (toArray xs)

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

difference :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
difference xs = adaptAny $ difference' xs

difference' :: forall a. Eq a => NonEmptyArray a -> Array a -> Array a
difference' xs = A.difference $ toArray xs

intersect :: forall a . Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
intersect = intersectBy eq

intersect' :: forall a . Eq a => NonEmptyArray a -> Array a -> Array a
intersect' = intersectBy' eq

intersectBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> Array a
intersectBy eq xs = intersectBy' eq xs <<< toArray

intersectBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> Array a
intersectBy' eq xs = A.intersectBy eq (toArray xs)

infix 5 difference as \\

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex


allow chooseInt to work with 32 bit intervals

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math ((%))

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = floor <<< clamp <$> choose32BitNumber
  where
  choose32BitNumber :: Gen Number
  choose32BitNumber = (+) <$> choose31BitNumber <*> choose31BitNumber

  choose31BitNumber :: Gen Number
  choose31BitNumber = toNumber <$> lcgStep

  clamp :: Number -> Number
  clamp x = case x % (numB - numA + one) of
              r | r >= 0.0 -> numA + r
                | otherwise -> numB + r + one
  numA = toNumber a
  numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (state, modify)

import Data.Array ((!!), length)
import Data.Foldable (fold)
import Data.Int (toNumber)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)

import Math as M

import Test.QuickCheck.LCG (Seed, lcgPerturb, lcgN, lcgNext, runSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ Tuple x xs

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen


[CSE-42] Fix sumCoinOfInputsOutputs

[CSE-42] Fix sumCoinOfInputsOutputs

as suggested by @ksaric

module Explorer.Util.Factory where

import Prelude
import Data.Foldable (sum)
import Data.Lens ((^.))
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Pos.Core.Lenses.Types (_Coin, getCoin)
import Pos.Core.Types (Coin(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary(..), CHash(..), CTxEntry(..), CTxId(..))

mkCHash :: String -> CHash
mkCHash = CHash

mkCTxId :: String -> CTxId
mkCTxId =
    CTxId <<< mkCHash

mkCoin :: Int -> Coin
mkCoin coin =
  Coin {getCoin: coin}

mkCAddress :: String -> CAddress
mkCAddress = CAddress

-- | Helper to summarize coins by a list of Tx inputs or outputs
sumCoinOfInputsOutputs :: Array (Tuple CAddress Coin) -> Coin
sumCoinOfInputsOutputs addressList =
    mkCoin <<< sum $ addressCoins <$> addressList
      where
        -- | Get total number of coins from an address
        addressCoins :: (Tuple CAddress Coin) -> Int
        addressCoins (Tuple _ coin) = coin ^. (_Coin <<< getCoin)

-- All the following helper function `mkEmpty**` are for debugging only
-- We do need these to mock live data
-- It can be removed if all endpoints are ready

mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin 0
    }

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caTxNum: 0
    , caBalance: mkCoin 0
    , caTxList: []
    }

module Explorer.Util.Factory where

import Prelude
import Data.Array (foldl)
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Data.Lens ((^.))
import Pos.Core.Lenses.Types (_Coin, getCoin)
import Pos.Core.Types (Coin(..))
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary(..), CHash(..), CTxEntry(..), CTxId(..))

mkCHash :: String -> CHash
mkCHash = CHash

mkCTxId :: String -> CTxId
mkCTxId =
    CTxId <<< mkCHash

mkCoin :: Int -> Coin
mkCoin coin =
  Coin {getCoin: coin}

mkCAddress :: String -> CAddress
mkCAddress = CAddress

-- | Helper to summarize coins by a list of Tx inputs or outputs
sumCoinOfInputsOutputs :: Array (Tuple CAddress Coin) -> Coin
sumCoinOfInputsOutputs list =
    mkCoin $ foldl (\acc (Tuple _ coin) -> (+) acc $ coin ^. (_Coin <<< getCoin)) 0 list

-- All the following helper function `mkEmpty**` are for debugging only
-- We do need these to mock live data
-- It can be removed if all endpoints are ready

mkEmptyCTxEntry :: CTxEntry
mkEmptyCTxEntry = CTxEntry
    { cteId: mkCTxId "--"
    , cteTimeIssued: mkTime 0.0
    , cteAmount: mkCoin 0
    }

mkEmptyCAddressSummary :: CAddressSummary
mkEmptyCAddressSummary = CAddressSummary
    { caAddress: mkCAddress "--"
    , caTxNum: 0
    , caBalance: mkCoin 0
    , caTxList: []
    }


Patch for #87

Patch for #87

-- | The main module of the Halogen library. It defines functions for running applications
-- | assembled from the parts defined in the various submodules:
-- |
-- | - `Halogen.Signal` for responding to inputs and maintaining state
-- | - `Halogen.HTML.*` for templating HTML documents
-- | - `Halogen.Component` for building application components
-- | - `Halogen.Themes.*` for rendering using common front-end libraries
-- | - `Halogen.Mixin.*` for common additional application features
-- |
-- | The functionality of this library is completely described by the type signature of the `runUI`
-- | function, which renders a `Component` to the DOM. The other modules exist to make the construction
-- | of `Component`s as simple as possible.
-- |
module Halogen
  ( HalogenEffects()
  , Driver()

  , changes

  , runUI
  ) where

import DOM
import Data.DOM.Simple.Types

import Data.Void
import Data.Maybe
import Data.Tuple
import Data.Either
import Data.Bifunctor (rmap)

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Exception

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Renderer.VirtualDOM as R

import Halogen.Signal
import Halogen.Component
import Halogen.HTML.Events.Monad
import Halogen.Internal.VirtualDOM (VTree(), Patch(), Widget(), diff, patch, createElement)

-- | Wraps the effects required by the `runUI` function.
type HalogenEffects eff = (trace :: Trace, ref :: Ref, dom :: DOM | eff)

-- | A signal which emits patches corresponding to successive `VTree`s.
-- |
-- | This function can be used to create alternative top-level handlers which use `virtual-dom`.
changes :: VTree -> SF VTree Patch
changes = differencesWith diff

-- | This type synonym is provided to tidy up the type signature of `runUI`.
-- |
-- | The _driver function_ can be used by the caller to inject additional inputs into the system at the top-level.
-- |
-- | This is useful for supporting applications which respond to external events which originate
-- | outside the UI, such as timers or hash-change events.
-- |
-- | For example, to drive the UI with a `Tick` input every second, we might write something like the following:
-- |
-- | ```purescript
-- | main = do
-- |   Tuple node driver <- runUI ui
-- |   appendToBody node
-- |   setInterval 1000 $ driver Tick
-- | ```
type Driver i eff = i -> Eff (HalogenEffects eff) Unit

-- | `runUI` renders a `Component` to the DOM using `virtual-dom`.
-- |
-- | This function is the workhorse of the Halogen library. It can be called in `main`
-- | to set up the application and create the driver function, which can be used to
-- | send inputs to the UI from external components.
runUI :: forall req eff.
           Component (Widget (HalogenEffects eff) req) (Event (HalogenEffects eff)) req req ->
           Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI = runComponent \sf -> do
  ref <- newRef Nothing
  runUI' ref sf

-- | Internal function used in the implementation of `runUI`.
runUI' :: forall i req eff.
            RefVal (Maybe { signal :: SF (Either i req) Patch, node :: HTMLElement }) ->
            SF1 (Either i req) (H.HTML (Widget (HalogenEffects eff) req) (Event (HalogenEffects eff) (Either i req))) ->
            Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI' ref sf = do
  let render = R.renderHTML requestHandler widgetHandler
      vtrees = render <$> sf
      diffs  = tail vtrees >>> changes (head vtrees)
      node   = createElement (head vtrees)
  writeRef ref $ Just { signal: diffs, node: node }
  return (Tuple node externalDriver)

  where
  requestHandler :: Event (HalogenEffects eff) (Either i req) -> Eff (HalogenEffects eff) Unit
  requestHandler aff = unsafeInterleaveEff $ runEvent logger driver aff

  widgetHandler :: Widget (HalogenEffects eff) req -> Widget (HalogenEffects eff) (Event (HalogenEffects eff) (Either i req))
  widgetHandler = ((pure <<< Right) <$>)

  logger :: Error -> Eff (HalogenEffects eff) Unit
  logger e = trace $ "Uncaught error in asynchronous code: " <> message e

  driver :: Driver (Either i req) eff
  driver e = do
    ms <- readRef ref
    case ms of
      Just { signal: signal, node: node } -> do
        let next = runSF signal e
        node' <- patch (head next) node
        writeRef ref $ Just { signal: tail next, node: node' }
      Nothing -> trace "Error: An attempt to re-render was made during the initial render."

  externalDriver :: Driver req eff
  externalDriver req = driver (Right req)

-- | The main module of the Halogen library. It defines functions for running applications
-- | assembled from the parts defined in the various submodules:
-- |
-- | - `Halogen.Signal` for responding to inputs and maintaining state
-- | - `Halogen.HTML.*` for templating HTML documents
-- | - `Halogen.Component` for building application components
-- | - `Halogen.Themes.*` for rendering using common front-end libraries
-- | - `Halogen.Mixin.*` for common additional application features
-- |
-- | The functionality of this library is completely described by the type signature of the `runUI`
-- | function, which renders a `Component` to the DOM. The other modules exist to make the construction
-- | of `Component`s as simple as possible.
-- |
module Halogen
  ( HalogenEffects()
  , Driver()

  , changes

  , runUI
  ) where

import DOM
import Data.DOM.Simple.Types

import Data.Void
import Data.Maybe
import Data.Tuple
import Data.Either
import Data.Bifunctor (rmap)

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Exception

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Renderer.VirtualDOM as R

import Halogen.Signal
import Halogen.Component
import Halogen.HTML.Events.Monad
import Halogen.Internal.VirtualDOM (VTree(), Patch(), Widget(), diff, patch, createElement)

-- | Wraps the effects required by the `runUI` function.
type HalogenEffects eff = (trace :: Trace, ref :: Ref, dom :: DOM | eff)

-- | A signal which emits patches corresponding to successive `VTree`s.
-- |
-- | This function can be used to create alternative top-level handlers which use `virtual-dom`.
changes :: VTree -> SF VTree Patch
changes = differencesWith diff

-- | This type synonym is provided to tidy up the type signature of `runUI`.
-- |
-- | The _driver function_ can be used by the caller to inject additional inputs into the system at the top-level.
-- |
-- | This is useful for supporting applications which respond to external events which originate
-- | outside the UI, such as timers or hash-change events.
-- |
-- | For example, to drive the UI with a `Tick` input every second, we might write something like the following:
-- |
-- | ```purescript
-- | main = do
-- |   Tuple node driver <- runUI ui
-- |   appendToBody node
-- |   setInterval 1000 $ driver Tick
-- | ```
type Driver i eff = i -> Eff (HalogenEffects eff) Unit

-- | `runUI` renders a `Component` to the DOM using `virtual-dom`.
-- |
-- | This function is the workhorse of the Halogen library. It can be called in `main`
-- | to set up the application and create the driver function, which can be used to
-- | send inputs to the UI from external components.
runUI :: forall req eff.
           Component (Widget (HalogenEffects eff) req) (Event (HalogenEffects eff)) req req ->
           Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI = runComponent \sf -> do
  ref <- newRef Nothing
  runUI' ref sf

-- | Internal function used in the implementation of `runUI`.
runUI' :: forall i req eff.
            RefVal (Maybe { signal :: SF (Either i req) Patch, node :: HTMLElement }) ->
            SF1 (Either i req) (H.HTML (Widget (HalogenEffects eff) req) (Event (HalogenEffects eff) (Either i req))) ->
            Eff (HalogenEffects eff) (Tuple HTMLElement (Driver req eff))
runUI' ref sf = do
  let render = R.renderHTML requestHandler widgetHandler
      vtrees = render <$> sf
      diffs  = tail vtrees >>> changes (head vtrees)
      node   = createElement (head vtrees)
  writeRef ref $ Just { signal: diffs, node: node }
  return (Tuple node externalDriver)

  where
  requestHandler :: Event (HalogenEffects eff) (Either i req) -> Eff (HalogenEffects eff) Unit
  requestHandler aff = unsafeInterleaveEff $ runEvent logger driver aff

  widgetHandler :: Widget (HalogenEffects eff) req -> Widget (HalogenEffects eff) (Event (HalogenEffects eff) (Either i req))
  widgetHandler = ((pure <<< Right) <$>)

  logger :: Error -> Eff (HalogenEffects eff) Unit
  logger e = trace $ "Uncaught error in asynchronous code: " <> message e

  driver :: Driver (Either i req) eff
  driver e = do
    Just { signal: signal, node: node } <- readRef ref
    let next = runSF signal e
    node' <- patch (head next) node
    writeRef ref $ Just { signal: tail next, node: node' }

  externalDriver :: Driver req eff
  externalDriver req = driver (Right req)


[CSE-193] Add `ja` translations

[CSE-193] Add `ja` translations

module Explorer.I18n.JP where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "戻る"
        , cApi: "API"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "トランザクション"
        , cTransactions: "トランザクション"
        , cTransactionFeed: "トランザクションフィード"
        , cAddress: "アドレス"
        , cAddresses: "アドレス"
        , cVersion: "バージョン"
        , cCalculator: "計算機"
        , cNetwork: "ネットワーク"
        , cSummary: "概要"
        , cBlock: "スロット"
        , cGenesis: "ジェネシス・ブロック"
        , cHash: "ハッシュ値"
        , cHashes: "ハッシュ値"
        , cEpoch: "エポック"
        , cEpochs: "エポック"
        , cSlot: "スロット"
        , cSlots: "スロット"
        , cAge: "経過時間"
        , cTotalSent: "総送信額"
        , cBlockLead: "スロットリーダー"
        , cSize: "サイズ (bytes)"
        , cExpand: "開く"
        , cCollapse: "閉じる"
        , cNoData: "データなし"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "不明"
        , cTotalOutput: "合計アウトプット"
        , cOf: "of"
        , cNotAvailable: "データがありません"
        , cLoading: "ロード中..."
        , cBack2Dashboard: "ダッシュボードに戻る"
        , cYes: "はい"
        , cNo: "いいえ"
        , cDays: "日"
        , cHours: "時間"
        , cMinutes: "分"
        , cSeconds: "秒"
        , cDateFormat: "YYYY/MM/DD HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "ホーム"
        , navBlockchain: "ブロックチェーン"
        , navMarket: "マーケット"
        , navCharts: "チャート"
        , navTools: "ツール"
        }
    , hero:
        {  hrSubtitle: "カルダノネットワーク上のアドレス、トランザクション、エポック、スロットを検索"
        , hrSearch: "スロット、エポック、トランザクションを検索"
        , hrTime: "タイム"
        }
    , dashboard:
        { dbTitle: "ダッシュボード"
        , dbLastBlocks: "最近のスロット"
        , dbLastBlocksDescription: "{0}に{1}のトランザクションが生成されました"
        , dbPriceAverage: "平均価格"
        , dbPriceForOne: "1{1}の価格: {0}"
        , dbPriceSince: "昨日からの価格: {0}"
        , dbTotalSupply: "総供給額"
        , dbTotalAmountOf: "システム内総額: {0}"
        , dbTotalAmountOfTransactions: "開設以来システム内で検出された総トランザクション数"
        , dbExploreBlocks: "スロットを検索する"
        , dbExploreTransactions: "トランザクションを検索する"
        , dbBlockchainOffer: "ブロックチェーンエクスプローラーから提供されるもの"
        , dbBlockSearch: "スロット検索"
        , dbBlockSearchDescription: "スロットはトランザクションを格納しているボックスです。"
        , dbAddressSearch: "アドレス検索"
        , dbAddressSearchDescription: "アドレスを検索します"
        , dbTransactionSearch: "トランザクション検索"
        , dbTransactionSearchDescription: "トランザクションはAからBへコインを送金することです。"
        , dbApiDescription: "我々の安全なAPIは、さまざまな言語とSDKで利用可能です。"
        , dbGetAddress: "アドレス取得"
        , dbResponse: "レスポンス"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "APIキー取得"
        , dbMoreExamples: "その他の例を見る"
        , dbAboutBlockchain: "ブロックチェーンについて"
        , dbAboutBlockchainDescription: "ブロックチェーンAPIはより容易に暗号通貨のアプリケーション及び機能を実装することができます。我々は開発者が高速、スケーラブル、かつ安全なサービスを構築できるようなプラットフォームを提供することに注力しています。

このAPIはベータ版では無料で無制限です。APIはまだ初期段階であり、今後より多くのエンドポイント、機能の導入を予定しています。開発チームはユーザーが求めているAPIを構築したいので、リクエスト、改善点などがあればご連絡お願いします。"
        }
    , address:
        { addScan: "QRコードをスキャンしてアドレスをクリップボードにコピーする"
        , addQrCode: "QRコード"
        , addFinalBalance: "最終残高"
        , addNotFound: "アドレスは存在しません"
        }
    , tx:
        { txTime: "入金時刻"
        , txIncluded: "含まれている"
        , txRelayed: "中継IP"
        , txEmpty: "トランザクションなし"
        , txFees: "トランザクション料"
        , txNotFound: "トランザクションは見つかりません"
        }
    , block:
        { blFees: "手数料"
        , blEstVolume: "推定容量"
        , blPrevBlock: "前のスロット"
        , blNextBlock: "次のスロット"
        , blRoot: "ハッシュ根"
        , blEpochSlotNotFound: "エポック / スロットは存在していません。"
        , blSlotNotFound: "スロットは存在していません。"
        }
    , genesisBlock:
        { gblNotFound: "ジェネシス・ブロックは見つかりませんでした"
        , gblNumberRedeemedAddresses: "還元済みアドレス"
        , gblNumberNotRedeemedAddresses: "還元可能なアドレス数"
        , gblNumberAddressesToRedeem: "還元アドレス数"
        , gblRedeemedAmountTotal: "還元済み"
        , gblNonRedeemedAmountTotal: "未還元数"
        , gblFilterAll: "全て"
        , gblFilterRedeemed: "還元済み"
        , gblFilterNonRedeemed: "未還元"
        , gblAddressesNotFound: "そのアドレスは存在しません"
        , gblAddressesError: "アドレス読み込み中にエラーが発生しました."
        , gblAddressRedeemAmount: "還元される額"
        , gblAddressIsRedeemed: "還元済み"
        }
    , footer:
        { fooIohkSupportP: "IOHK supported project"
        , fooGithub: "Github"
        , fooEmail: "Email"
        , fooTwitter: "Twitter"
        , fooDaedalusPlatform: "ダイダロスプラットフォーム"
        , fooWhyCardano: "なぜカルダノなのか"
        , fooCardanoRoadmap: "カルダノロードマップ"
        , fooCardanoSource: "カルダノSLソース"
        , fooCardanoFoundation: "カルダノ財団"
        , fooCardanoFoundationYoutube: "カルダノ財団 Youtube"
        , fooCardanoFoundationTwitter: "カルダノ財団 Twitter"
        , fooCardanoHub: "カルダノハブ"
        , fooCardanoLaunch: "カルダノローンチ"
        , fooCardanoSlack: "カルダノ財団 Slack"
        , fooCardanoReddit: "カルダノ財団 Reddit"
        , fooCardanoCommunity: "カルダノコミュニティー"
        , fooCardanoDocumentation: "カルダノドキュメンテーション"
        , fooCardanoTestnet: "カルダノテストネット"
        , fooCardanoOpenSource: "カルダノはオープンソースプロジェクトです"
        , fooIOHK: "IOHK"
        , fooIOHKBlog: "IOHKブログ"
        , fooIOHKYoutube: "IOHK YouTube"
        , fooDisclaimerPt1: "カルダノは、ソフトウェアプラットフォームのみであり、ブロックチェーン資産、デジタル通貨、暗号通貨またはそれに関連する各資金の精査や実質的なレビューは一切行いません。あなたは自身の投資評価、ブロックチェーン資産を交換するかどうかの決定、ブロックチェーン資産をカルダノと交換の如何に関して、完全かつ唯一の責任があります。多くの場合、あなたの調査に基づいて交換するブロックチェーン資産は価値が上がらず、下がる可能性があります。同様に、調査を基に交換するブロックチェーン資産は、交換後に価値が上がる可能性もあります。"
        , fooDisclaimerPt2: "過去の業績は必ずしも将来の結果を 暗 示す るものではありません。ブロックチェーン資産への投資には、投資の一部または全てが失われるリスクが伴います。換金するブロックチェーン資産の価値は、市場リスクおよびその他の投資リスクの対象となります。"
        , fooProject: "プロジェクト"
        , fooProtocol: "プロトコル"
        , fooFoundation: "財団"
        , fooLearnMore: "詳しく知る"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "ページが見つかりません"
        }
    }

module Explorer.I18n.JP where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "戻る"
        , cApi: "API"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "トランザクション"
        , cTransactions: "トランザクション"
        , cTransactionFeed: "トランザクションフィード"
        , cAddress: "アドレス"
        , cAddresses: "アドレス"
        , cVersion: "バージョン"
        , cCalculator: "計算機"
        , cNetwork: "ネットワーク"
        , cSummary: "概要"
        , cBlock: "スロット"
        , cGenesis: "ジェネシス・ブロック"
        , cHash: "ハッシュ値"
        , cHashes: "ハッシュ値"
        , cEpoch: "エポック"
        , cEpochs: "エポック"
        , cSlot: "スロット"
        , cSlots: "スロット"
        , cAge: "経過時間"
        , cTotalSent: "総送信額"
        , cBlockLead: "スロットリーダー"
        , cSize: "サイズ (bytes)"
        , cExpand: "開く"
        , cCollapse: "閉じる"
        , cNoData: "データなし"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "不明"
        , cTotalOutput: "合計アウトプット"
        , cOf: "of"
        , cNotAvailable: "データがありません"
        , cLoading: "ロード中..."
        , cBack2Dashboard: "ダッシュボードに戻る"
        , cYes: "はい"
        , cNo: "いいえ"
        , cDays: "日"
        , cHours: "時間"
        , cMinutes: "分"
        , cSeconds: "秒"
        , cDateFormat: "YYYY/MM/DD HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "ホーム"
        , navBlockchain: "ブロックチェーン"
        , navMarket: "マーケット"
        , navCharts: "チャート"
        , navTools: "ツール"
        }
    , hero:
        {  hrSubtitle: "カルダノネットワーク上のアドレス、トランザクション、エポック、スロットを検索"
        , hrSearch: "スロット、エポック、トランザクションを検索"
        , hrTime: "タイム"
        }
    , dashboard:
        { dbTitle: "ダッシュボード"
        , dbLastBlocks: "最近のスロット"
        , dbLastBlocksDescription: "{0}に{1}のトランザクションが生成されました"
        , dbPriceAverage: "平均価格"
        , dbPriceForOne: "1{1}の価格: {0}"
        , dbPriceSince: "昨日からの価格: {0}"
        , dbTotalSupply: "総供給額"
        , dbTotalAmountOf: "システム内総額: {0}"
        , dbTotalAmountOfTransactions: "開設以来システム内で検出された総トランザクション数"
        , dbExploreBlocks: "スロットを検索する"
        , dbExploreTransactions: "トランザクションを検索する"
        , dbBlockchainOffer: "ブロックチェーンエクスプローラーから提供されるもの"
        , dbBlockSearch: "スロット検索"
        , dbBlockSearchDescription: "スロットはトランザクションを格納しているボックスです。"
        , dbAddressSearch: "アドレス検索"
        , dbAddressSearchDescription: "アドレスを検索します"
        , dbTransactionSearch: "トランザクション検索"
        , dbTransactionSearchDescription: "トランザクションはAからBへコインを送金することです。"
        , dbApiDescription: "我々の安全なAPIは、さまざまな言語とSDKで利用可能です。"
        , dbGetAddress: "アドレス取得"
        , dbResponse: "レスポンス"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "APIキー取得"
        , dbMoreExamples: "その他の例を見る"
        , dbAboutBlockchain: "ブロックチェーンについて"
        , dbAboutBlockchainDescription: "ブロックチェーンAPIはより容易に暗号通貨のアプリケーション及び機能を実装することができます。我々は開発者が高速、スケーラブル、かつ安全なサービスを構築できるようなプラットフォームを提供することに注力しています。

このAPIはベータ版では無料で無制限です。APIはまだ初期段階であり、今後より多くのエンドポイント、機能の導入を予定しています。開発チームはユーザーが求めているAPIを構築したいので、リクエスト、改善点などがあればご連絡お願いします。"
        }
    , address:
        { addScan: "QRコードをスキャンしてアドレスをクリップボードにコピーする"
        , addQrCode: "QRコード"
        , addFinalBalance: "最終残高"
        , addNotFound: "アドレスは存在しません"
        }
    , tx:
        { txTime: "入金時刻"
        , txIncluded: "含まれている"
        , txRelayed: "中継IP"
        , txEmpty: "トランザクションなし"
        , txFees: "トランザクション料"
        , txNotFound: "トランザクションは見つかりません"
        }
    , block:
        { blFees: "手数料"
        , blEstVolume: "推定容量"
        , blPrevBlock: "前のスロット"
        , blNextBlock: "次のスロット"
        , blRoot: "ハッシュ根"
        , blEpochSlotNotFound: "エポック / スロットは存在していません。"
        , blSlotNotFound: "スロットは存在していません。"
        }
    , genesisBlock:
        { gblNotFound: "ジェネシス・ブロックは見つかりませんでした"
        , gblNumberRedeemedAddresses: "還元済みアドレス"
        , gblNumberNotRedeemedAddresses: "JA - Addresses left to redeem"
        , gblNumberAddressesToRedeem: "JA - Redeem addresses"
        , gblRedeemedAmountTotal: "JA - Redeemed amount"
        , gblNonRedeemedAmountTotal: "JA - Amount left to redeem"
        , gblFilterAll: "JA - All"
        , gblFilterRedeemed: "JA - Redeemed"
        , gblFilterNonRedeemed: "JA - Not redeemed"
        , gblAddressesNotFound: "そのアドレスは存在しません"
        , gblAddressesError: "アドレス読み込み中にエラーが発生しました."
        , gblAddressRedeemAmount: "還元される額"
        , gblAddressIsRedeemed: "還元済み"
        }
    , footer:
        { fooIohkSupportP: "IOHK supported project"
        , fooGithub: "Github"
        , fooEmail: "Email"
        , fooTwitter: "Twitter"
        , fooDaedalusPlatform: "ダイダロスプラットフォーム"
        , fooWhyCardano: "なぜカルダノなのか"
        , fooCardanoRoadmap: "カルダノロードマップ"
        , fooCardanoSource: "カルダノSLソース"
        , fooCardanoFoundation: "カルダノ財団"
        , fooCardanoFoundationYoutube: "カルダノ財団 Youtube"
        , fooCardanoFoundationTwitter: "カルダノ財団 Twitter"
        , fooCardanoHub: "カルダノハブ"
        , fooCardanoLaunch: "カルダノローンチ"
        , fooCardanoSlack: "カルダノ財団 Slack"
        , fooCardanoReddit: "カルダノ財団 Reddit"
        , fooCardanoCommunity: "カルダノコミュニティー"
        , fooCardanoDocumentation: "カルダノドキュメンテーション"
        , fooCardanoTestnet: "カルダノテストネット"
        , fooCardanoOpenSource: "カルダノはオープンソースプロジェクトです"
        , fooIOHK: "IOHK"
        , fooIOHKBlog: "IOHKブログ"
        , fooIOHKYoutube: "IOHK YouTube"
        , fooDisclaimerPt1: "カルダノは、ソフトウェアプラットフォームのみであり、ブロックチェーン資産、デジタル通貨、暗号通貨またはそれに関連する各資金の精査や実質的なレビューは一切行いません。あなたは自身の投資評価、ブロックチェーン資産を交換するかどうかの決定、ブロックチェーン資産をカルダノと交換の如何に関して、完全かつ唯一の責任があります。多くの場合、あなたの調査に基づいて交換するブロックチェーン資産は価値が上がらず、下がる可能性があります。同様に、調査を基に交換するブロックチェーン資産は、交換後に価値が上がる可能性もあります。"
        , fooDisclaimerPt2: "過去の業績は必ずしも将来の結果を 暗 示す るものではありません。ブロックチェーン資産への投資には、投資の一部または全てが失われるリスクが伴います。換金するブロックチェーン資産の価値は、市場リスクおよびその他の投資リスクの対象となります。"
        , fooProject: "プロジェクト"
        , fooProtocol: "プロトコル"
        , fooFoundation: "財団"
        , fooLearnMore: "詳しく知る"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "ページが見つかりません"
        }
    }


code cleanup

code cleanup

module Graphics.Three.Object3D where

import Graphics.Three.Math.Vector
import Graphics.Three.Math.Euler
import Graphics.Three.Types
import Graphics.Three.Util
import Control.Monad.Eff

import qualified Graphics.Three.Material as M
import qualified Graphics.Three.Geometry as G

foreign import data Mesh :: *
foreign import data Line :: *

class Object3D a

instance object3DMesh :: Object3D Mesh
instance object3DLine :: Object3D Line

class Renderable a

instance renderableMesh :: Renderable Mesh
instance renderableLine :: Renderable Line

data LineType = LineStrip | LinePieces

instance showLineType :: Show LineType where
    show LineStrip  = "LineStrip"
    show LinePieces = "LinePieces"

createMesh :: forall a. (M.Material a) => G.Geometry -> a -> ThreeEff Mesh
createMesh = ffi ["geometry", "material", ""] "new THREE.Mesh(geometry, material)"

createLine :: forall a. (M.Material a) => G.Geometry -> a -> LineType -> ThreeEff Line
createLine g m t = create g m $ show t
    where
        create = ffi ["geometry", "material", "lineType", ""] "new THREE.Line(geometry, material)"

getPosition :: forall a. (Object3D a) => a -> ThreeEff Vector3
getPosition = ffi ["object", ""] "object.position"

setPosition :: forall a. (Object3D a) => a -> Number -> Number -> Number -> ThreeEff Unit
setPosition = fpi ["object", "x", "y", "z", ""] "object.position.set(x, y, z)" --TODO change to vector?

getRotationEuler :: forall a. (Object3D a) => a -> Number -> Number -> Number -> ThreeEff Euler
getRotationEuler = ffi ["object", ""] "object.rotation"

setRotationEuler :: forall a. (Object3D a) => a -> Number -> Number -> Number -> ThreeEff Unit
setRotationEuler = fpi ["object", "x", "y", "z", ""] "object.rotation.set(x, y, z)" --TODO change to euler? Add order

rotateIncrement :: forall a. (Object3D a) => a -> Number -> Number -> Number -> ThreeEff Unit
rotateIncrement = fpi ["object", "x", "y", "z", ""]
    "object.rotation.x += x; object.rotation.y += y; object.rotation.z += z;"

getGeometry :: forall a. (Renderable a) => a -> ThreeEff G.Geometry
getGeometry = ffi ["object", ""] "object.geometry"

getMaterial :: forall a b. (Renderable a, M.Material b) => a -> ThreeEff b
getMaterial = ffi ["object", ""] "object.material"