Bugfix: Correct pretty printing of append

module AST where

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

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

derive instance eqOp :: Eq Op

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

type ExprQual = Qual Binding Expr

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

type TypeQual  = QualTree TypeBinding TypeTree Type

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

type IndexQual = QualTree IBinding IndexTree Int

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

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

type TVar = String

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

data AD
    = TList Type
    | TTuple (List Type)

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

derive instance eqExpr :: Eq Expr

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

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

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

derive instance eqBinding :: Eq Binding

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

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

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

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

derive instance eqDefinition :: Eq Definition

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

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

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

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

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

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

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

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

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

derive instance eqType :: Eq Type

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

derive instance eqAD :: Eq AD

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

derive instance eqTypeError :: Eq TypeError

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

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

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

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

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

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

module AST where

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

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

derive instance eqOp :: Eq Op

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

type ExprQual = Qual Binding Expr

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

type TypeQual  = QualTree TypeBinding TypeTree Type

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

type IndexQual = QualTree IBinding IndexTree Int

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

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

type TVar = String

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

data AD
    = TList Type
    | TTuple (List Type)

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

derive instance eqExpr :: Eq Expr

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

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

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

derive instance eqBinding :: Eq Binding

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

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

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

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

derive instance eqDefinition :: Eq Definition

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

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

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

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

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

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

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

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

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

derive instance eqType :: Eq Type

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

derive instance eqAD :: Eq AD

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

derive instance eqTypeError :: Eq TypeError

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

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

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

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

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

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


Improved shuffling

Improved shuffling

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

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Eff.Class (liftEff)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

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

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

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

decode :: ∀ r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries (Array String))
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) (Array String)
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text ""
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0

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

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Eff.Class (liftEff)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either(..), either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

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

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

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

decode :: ∀ r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries (Array String))
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< (\answers -> Tuple countries answers) <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) (Array String)
pick xs = shuffle <<< take answerCount $ _.name <<< unwrap <$> xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text ""
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0


Using explicit 'forall' over its symbol equivalent

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

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

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

decode :: forall r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Names)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) Names
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text mempty
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0

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

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

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

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

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

decode :: ∀ r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Names)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) Names
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text mempty
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0


Attempt unlink

Attempt unlink

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getModulesForFileTemp
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Prelude
import Node.FS.Aff as FS
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff, attempt)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array (findLastIndex, filter, singleton, concatMap, (:))
import Data.Either (either, Either(..))
import Data.Foldable (all, notElem, elem)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Newtype (class Newtype)
import Data.String (Pattern(Pattern), split)
import Data.String.Regex (regex) as R
import Data.String.Regex.Flags (global, noFlags, multiline) as R
import IdePurescript.Regex (replace', match', test')
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (sep)
import PscIde.Command (ImportType(..))

newtype Module = Module
  { moduleName :: String
  , importType :: C.ImportType
  , qualifier  :: Maybe String
  }

derive instance moduleNewtype :: Newtype Module _

instance moduleEq :: Eq Module where
  eq (Module m1) (Module m2) =
    m1.moduleName == m2.moduleName &&
    m1.qualifier == m2.qualifier &&
    m1.importType `eqImportType` m2.importType

eqImportType :: C.ImportType -> C.ImportType -> Boolean
eqImportType Implicit Implicit = true
eqImportType (Explicit idents) (Explicit idents') = idents == idents'
eqImportType (Hiding idents) (Hiding idents') = idents == idents'
eqImportType _ _ = false

getModuleName :: Module -> String
getModuleName (Module { moduleName }) = moduleName

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case match' regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.multiline

getModulesForFile :: forall eff. Int -> Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile port file fullText = do
  C.ImportList { moduleName, imports } <- either (const default) id <$> P.listImports port file
  let modules = map mod imports
      main = maybe (getMainModule fullText) Just moduleName
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  default = C.ImportList { moduleName: Nothing, imports: [] }
  mod (C.Import imp) = Module imp
  idents (Module { importType: Explicit ids }) = ids
  idents _ = []

getModulesForFileTemp :: forall eff. Int -> Path -> String -> Aff (net :: P.NET, fs :: FS | eff) State
getModulesForFileTemp port file fullText = do
  tmpFile <- makeTempFile file fullText
  res <- getModulesForFile port tmpFile fullText
  _ <- attempt $ FS.unlink tmpFile
  pure res

mkImplicit :: String -> Module
mkImplicit m = Module { qualifier: Nothing, importType: Implicit, moduleName: m }

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules {modules, main} ident =
  map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> filter include modules
  where
  include (Module { qualifier: Just _ }) = false
  include (Module { importType: Explicit idents }) = maybe false (\x -> x `elem` idents || ("(" <> x <> ")") `elem` idents) ident
  include (Module { importType: Implicit }) = true
  include (Module { importType: Hiding idents }) =  maybe true (_ `notElem` idents) ident

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Module { qualifier: Just q' }) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split (Pattern "\n") text
      res = fromMaybe 0 $ findLastIndex (test' regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.TypeInfo) | FailedImport

makeTempFile :: forall eff. Path -> String -> Aff (fs :: FS | eff) Path
makeTempFile fileName text = do
  dir <- liftEff tmpDir
  let name = replace' (R.regex "[\\/\\\\:]" R.global) "-" fileName
      tmpFile = dir <> sep <> "ide-purescript-" <> name
  FS.writeTextFile UTF8 tmpFile text
  pure tmpFile

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  tmpFile <- makeTempFile fileName text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  _ <- attempt $ FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> Int -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state port fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport port tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && (mkImplicit moduleName `notElem` state.modules)

addExplicitImport :: forall eff. State -> Int -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state port fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport port tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && maybe true (\mn -> all (shouldAddMatch mn) state.modules) moduleName

    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Implicit })
      | moduleName' == mn = false
    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Hiding idents })
      | moduleName' == mn = identifier `elem` idents
    shouldAddMatch _ _ = true

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getModulesForFileTemp
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Prelude
import Node.FS.Aff as FS
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array (findLastIndex, filter, singleton, concatMap, (:))
import Data.Either (either, Either(..))
import Data.Foldable (all, notElem, elem)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Newtype (class Newtype)
import Data.String (Pattern(Pattern), split)
import Data.String.Regex (regex) as R
import Data.String.Regex.Flags (global, noFlags, multiline) as R
import IdePurescript.Regex (replace', match', test')
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (sep)
import PscIde.Command (ImportType(..))

newtype Module = Module
  { moduleName :: String
  , importType :: C.ImportType
  , qualifier  :: Maybe String
  }

derive instance moduleNewtype :: Newtype Module _

instance moduleEq :: Eq Module where
  eq (Module m1) (Module m2) =
    m1.moduleName == m2.moduleName &&
    m1.qualifier == m2.qualifier &&
    m1.importType `eqImportType` m2.importType

eqImportType :: C.ImportType -> C.ImportType -> Boolean
eqImportType Implicit Implicit = true
eqImportType (Explicit idents) (Explicit idents') = idents == idents'
eqImportType (Hiding idents) (Hiding idents') = idents == idents'
eqImportType _ _ = false

getModuleName :: Module -> String
getModuleName (Module { moduleName }) = moduleName

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case match' regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.multiline

getModulesForFile :: forall eff. Int -> Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile port file fullText = do
  C.ImportList { moduleName, imports } <- either (const default) id <$> P.listImports port file
  let modules = map mod imports
      main = maybe (getMainModule fullText) Just moduleName
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  default = C.ImportList { moduleName: Nothing, imports: [] }
  mod (C.Import imp) = Module imp
  idents (Module { importType: Explicit ids }) = ids
  idents _ = []

getModulesForFileTemp :: forall eff. Int -> Path -> String -> Aff (net :: P.NET, fs :: FS | eff) State
getModulesForFileTemp port file fullText = do
  tmpFile <- makeTempFile file fullText
  res <- getModulesForFile port tmpFile fullText
  FS.unlink tmpFile
  pure res

mkImplicit :: String -> Module
mkImplicit m = Module { qualifier: Nothing, importType: Implicit, moduleName: m }

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules {modules, main} ident =
  map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> filter include modules
  where
  include (Module { qualifier: Just _ }) = false
  include (Module { importType: Explicit idents }) = maybe false (\x -> x `elem` idents || ("(" <> x <> ")") `elem` idents) ident
  include (Module { importType: Implicit }) = true
  include (Module { importType: Hiding idents }) =  maybe true (_ `notElem` idents) ident

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< mkImplicit) main <> modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Module { qualifier: Just q' }) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split (Pattern "\n") text
      res = fromMaybe 0 $ findLastIndex (test' regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.TypeInfo) | FailedImport

makeTempFile :: forall eff. Path -> String -> Aff (fs :: FS | eff) Path
makeTempFile fileName text = do
  dir <- liftEff tmpDir
  let name = replace' (R.regex "[\\/\\\\:]" R.global) "-" fileName
      tmpFile = dir <> sep <> "ide-purescript-" <> name
  FS.writeTextFile UTF8 tmpFile text
  pure tmpFile

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  tmpFile <- makeTempFile fileName text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> Int -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state port fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport port tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && (mkImplicit moduleName `notElem` state.modules)

addExplicitImport :: forall eff. State -> Int -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state port fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport port tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && maybe true (\mn -> all (shouldAddMatch mn) state.modules) moduleName

    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Implicit })
      | moduleName' == mn = false
    shouldAddMatch mn (Module { moduleName: moduleName', qualifier: Nothing, importType: Hiding idents })
      | moduleName' == mn = identifier `elem` idents
    shouldAddMatch _ _ = true


Add a simple description.

Add a simple description.


Add more tests on attribute value.

Add more tests on attribute value.

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Either
import Data.Foldable
import Data.List
import Text.Parsing.StringParser (ParseError(..))

import Text.HTML.Parser
import Text.HTML.Parser.Array

import Test.Utils

main :: Eff (console :: CONSOLE) Unit
main = runTest do
  assertParse ""
    [ element "html" [] [] ]

  assertParse ""
    [ element "html" [] $
        [ element "body" [] []
        , element "head" [] []
        ]
    ]

  assertParse "
"
    [ voidElement "br" [] ]

  assertParse "

"
    [ element "p" [] [voidElement "br" []] ]

  assertParse "

"
    [ element "div" [] []
    , element "span" [] []
    ]

  assertParse "
hellobigworld!
"
    [ element "div" []
      [ textNode "hello"
      , element "em" [] [textNode "big"]
      , textNode "world!"
      ]
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "class" "bar"
      ] []
    ]

  assertParse """<div id = 'foo' disabled class =bar"<>
"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "disabled" ""
      , Attribute "class" """bar"<"""
      ] []
    ]

  assertParse """

"""
    [ element "div" [Attribute "id" "foo"]
      [ voidElement "img" [Attribute "src" "puppies.gif"] ]
    ]

    -- See if whitespace after attributes affect parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if unquoted attribute value is parsed properly...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if spaces around the equals sign affect attribute parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

assertParse
  :: forall eff f. (Foldable f)
  => String -> f HTML -> Eff (console :: CONSOLE | eff) Unit
assertParse input expected = case parseHTML input of
  Left (ParseError e) ->
    fail $ "Parse error for " <> show input <> "\n  Error: " <> e
  Right actual | actual /= expected' ->
    fail $ "Expected: " <> show expected' <> "\n  Actual: " <> show actual
  _ -> success input
  where
  expected' = fromFoldable expected

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Either
import Data.Foldable
import Data.List
import Text.Parsing.StringParser (ParseError(..))

import Text.HTML.Parser
import Text.HTML.Parser.Array

import Test.Utils

main :: Eff (console :: CONSOLE) Unit
main = runTest do
  assertParse ""
    [ element "html" [] [] ]

  assertParse ""
    [ element "html" [] $
        [ element "body" [] []
        , element "head" [] []
        ]
    ]

  assertParse "
"
    [ voidElement "br" [] ]

  assertParse "

"
    [ element "p" [] [voidElement "br" []] ]

  assertParse "

"
    [ element "div" [] []
    , element "span" [] []
    ]

  assertParse "
hellobigworld!
"
    [ element "div" []
      [ textNode "hello"
      , element "em" [] [textNode "big"]
      , textNode "world!"
      ]
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "class" "bar"
      ] []
    ]

  assertParse """<div id = 'foo' disabled class =bar"<>
"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "disabled" ""
      , Attribute "class" """bar"<"""
      ] []
    ]

  assertParse """

"""
    [ element "div" [Attribute "id" "foo"]
      [ voidElement "img" [Attribute "src" "puppies.gif"] ]
    ]

assertParse
  :: forall eff f. (Foldable f)
  => String -> f HTML -> Eff (console :: CONSOLE | eff) Unit
assertParse input expected = case parseHTML input of
  Left (ParseError e) ->
    fail $ "Parse error for " <> show input <> "\n  Error: " <> e
  Right actual | actual /= expected' ->
    fail $ "Expected: " <> show expected' <> "\n  Actual: " <> show actual
  _ -> success input
  where
  expected' = fromFoldable expected


removed tests

removed tests

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  log "You should add some tests."


Tweaking the field command

Tweaking the field command

module Database.Redis.Commands.Field where

import Database.Redis.Commands.Property
import Database.Redis.Commands.String

newtype Field a = Field Value

instance valField :: Val (Field a) where
  value (Field v) = v

data Name
data Prop

name :: String -> Field Name
name n = Field $ fromString n

field :: String -> String -> Field Prop
field a b = Field $ (fromString a <> fromString "->" <> fromString b)

module Database.Redis.Commands.Field where

import Database.Redis.Commands.Property
import Database.Redis.Commands.String

newtype Field a = Field Value

instance valField :: Val (Field a) where
  value (Field v) = v

data Name

name :: String -> Field Name
name n = Field $ fromString n


explain the adjustment

explain the adjustment

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> LR (Array a)
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- in KCAPI there are cases where the length of the HP array
-- is neither 7 or 13, and it seems terminating "-1" elements
-- have a chance to disappear, so instead of using data from KCAPI
-- directly, we make sure the array is of the correct length
-- by applying this wrapper. "Nothing" will be appended to the
-- end of the list if the length is insufficient
ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (ensureHpsLen (1+12) $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (ensureHpsLen (1+12) $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = unsafeArrTail (ensureHpsLen (1+6) $ getInitHpsCombined battle)
    escortMaxHps = unsafeArrTail (ensureHpsLen (1+6) $ getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> LR (Array a)
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (ensureHpsLen (1+12) $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (ensureHpsLen (1+12) $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = unsafeArrTail (ensureHpsLen (1+6) $ getInitHpsCombined battle)
    escortMaxHps = unsafeArrTail (ensureHpsLen (1+6) $ getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2