refactored src/Web

refactored src/Web

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:))
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op MType

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List AST.emptyMeta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple AST.emptyMeta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary AST.emptyMeta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL AST.emptyMeta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR AST.emptyMeta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr AST.emptyMeta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr AST.emptyMeta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr AST.emptyMeta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr AST.emptyMeta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr AST.emptyMeta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda AST.emptyMeta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta x next end) start)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp AST.emptyMeta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp AST.emptyMeta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard AST.emptyMeta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let AST.emptyMeta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen AST.emptyMeta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App AST.emptyMeta func args
        argsDivs = zipList go (hole <<< App AST.emptyMeta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op t) = typedNode (pPrintOp op) ["op"] [] t

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:))
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, Meta (..), getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op MType

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List AST.emptyMeta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple AST.emptyMeta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary AST.emptyMeta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL AST.emptyMeta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR AST.emptyMeta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr AST.emptyMeta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr AST.emptyMeta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr AST.emptyMeta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr AST.emptyMeta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr AST.emptyMeta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda AST.emptyMeta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta x next end) start)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq AST.emptyMeta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp AST.emptyMeta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp AST.emptyMeta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard AST.emptyMeta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let AST.emptyMeta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen AST.emptyMeta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App AST.emptyMeta func args
        argsDivs = zipList go (hole <<< App AST.emptyMeta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op t) = typedNode (pPrintOp op) ["op"] [] t

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d


unsafeInnerText typo

unsafeInnerText typo

module Data.DOM.Simple.Unsafe.Element where

import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeGetElementById
  "function unsafeGetElementById(targ_id) {   \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.getElementById(targ_id);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeGetElementsByClassName
  "function unsafeGetElementsByClassName(targ_id) {   \
  \  return function (src) {                          \
  \    return function () {                           \
  \      return src.getElementsByClassName(targ_id);  \
  \    };                                             \
  \  }                                                \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetElementsByName
  "function unsafeGetElementsByName(targ_id) {      \
  \  return function (src) {                        \
  \    return function () {                         \
  \      return src.getElementsByName(targ_id);     \
  \    };                                           \
  \  };                                             \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeQuerySelector
  "function unsafeQuerySelector(selector) {   \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.querySelector(selector);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeQuerySelectorAll
  "function unsafeQuerySelectorAll(selector) {  \
  \  return function (src) {                    \
  \    return function () {                     \
  \      return src.querySelectorAll(selector); \
  \    };                                       \
  \  };                                         \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetAttribute
  "function unsafeGetAttribute(name) {      \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.getAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetAttribute
  "function unsafeSetAttribute(name) {      \
  \  return function (value) {              \
  \    return function (src) {              \
  \      return function () {               \
  \        src.setAttribute(name, value);   \
  \      };                                 \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeHasAttribute
  "function unsafeHasAttribute(name) {      \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.hasAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeRemoveAttribute
  "function unsafeRemoveAttribute(name) {   \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.removeAttribute(name);         \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeChildren
  "function unsafeChildren(src) {           \
  \    return function () {                 \
  \      return src.children;               \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeInnerHTML
  "function unsafeInnerHTML(src) {          \
  \  return function () {                   \
  \    return src.innerHTML;                \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerHTML
  "function unsafeSetInnerHTML(value) {     \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerHTML = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerText
  "function unsafeInnerText(src) {          \
  \  return function () {                   \
  \    return src.innerText;                \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerText
  "function unsafeSetInnerText(value) {     \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerText = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeContentWindow
  "function unsafeContentWindow(obj) {  \
  \  return function () {               \
  \    return obj.contentWindow;        \
  \  };                                 \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLWindow)

module Data.DOM.Simple.Unsafe.Element where

import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeGetElementById
  "function unsafeGetElementById(targ_id) {   \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.getElementById(targ_id);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeGetElementsByClassName
  "function unsafeGetElementsByClassName(targ_id) {   \
  \  return function (src) {                          \
  \    return function () {                           \
  \      return src.getElementsByClassName(targ_id);  \
  \    };                                             \
  \  }                                                \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetElementsByName
  "function unsafeGetElementsByName(targ_id) {      \
  \  return function (src) {                        \
  \    return function () {                         \
  \      return src.getElementsByName(targ_id);     \
  \    };                                           \
  \  };                                             \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeQuerySelector
  "function unsafeQuerySelector(selector) {   \
  \  return function (src) {                  \
  \    return function () {                   \
  \      return src.querySelector(selector);  \
  \    };                                     \
  \  };                                       \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeQuerySelectorAll
  "function unsafeQuerySelectorAll(selector) {  \
  \  return function (src) {                    \
  \    return function () {                     \
  \      return src.querySelectorAll(selector); \
  \    };                                       \
  \  };                                         \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetAttribute
  "function unsafeGetAttribute(name) {      \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.getAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetAttribute
  "function unsafeSetAttribute(name) {      \
  \  return function (value) {              \
  \    return function (src) {              \
  \      return function () {               \
  \        src.setAttribute(name, value);   \
  \      };                                 \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeHasAttribute
  "function unsafeHasAttribute(name) {      \
  \  return function (src) {                \
  \    return function () {                 \
  \      return src.hasAttribute(name);     \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeRemoveAttribute
  "function unsafeRemoveAttribute(name) {   \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.removeAttribute(name);         \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeChildren
  "function unsafeChildren(src) {           \
  \    return function () {                 \
  \      return src.children;               \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeInnerHTML
  "function unsafeInnerHTML(src) {          \
  \  return function () {                   \
  \    return src.innerHTML;                \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerHTML
  "function unsafeSetInnerHTML(value) {     \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerHTML = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerText
  "function innerText(src) {                \
  \  return function () {                   \
  \    return src.innerText;                \
  \  };                                     \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerText
  "function unsafeSetInnerText(value) {     \
  \  return function (src) {                \
  \    return function () {                 \
  \      src.innerText = value;             \
  \    };                                   \
  \  };                                     \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeContentWindow
  "function unsafeContentWindow(obj) {  \
  \  return function () {               \
  \    return obj.contentWindow;        \
  \  };                                 \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLWindow)


Improve error messages

Improve error messages

-- |
-- | Docopt FFI surface.
-- |
-- | Entrypoints to be called from JS-land.
-- | Data input and output is santized for either language and functions are
-- | curried/uncurried as needed.
-- |

module Docopt.FFI (
  run
, runFromSpec
, parse
, undefined
, readAsString
) where

import Prelude
import Debug.Trace
import Data.Function.Uncurried
import Data.Bifunctor (lmap)
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.List (toUnfoldable, List(Nil), fromFoldable)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Tuple (Tuple())
import Data.Tuple.Nested ((/\))
import Data.Array (singleton) as Array
import Data.Traversable (traverse, for)
import Control.Monad.Eff (Eff())
import Data.Either (Either(..), either)
import Data.StrMap (StrMap())
import Control.Bind ((=<<))
import Control.Alt (alt, (<|>))
import Data.String (toChar) as String
import Data.Foreign (readBoolean, readChar, readArray, readString, typeOf, toForeign,
                    readInt, readNumber, unsafeReadTagged) as F
import Data.Foreign (Foreign, F, ForeignError(..), typeOf, unsafeFromForeign,
                    toForeign)
import Data.Foreign.Class (readProp) as F
import Data.Foreign.NullOrUndefined as F
import Language.Docopt.Argument (Branch(), Argument(..), OptionArgumentObj)
import Unsafe.Coerce (unsafeCoerce)

import Docopt as Docopt
import Language.Docopt (Specification(), Docopt())
import Language.Docopt.Value (Value(..))

type RawValue = Unit

-- | Convert a Value into a JS-native value.
rawValue :: Value -> RawValue
rawValue (BoolValue   b) = unsafeCoerce b
rawValue (IntValue    i) = unsafeCoerce i
rawValue (FloatValue  x) = unsafeCoerce x
rawValue (StringValue s) = unsafeCoerce s
rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

foreign import isTruthy :: Foreign -> Boolean

-- |
-- | Run neodoc from JS.
-- |
run :: forall e.
  Fn2 String  -- ^ The neodoc text
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
run = mkFn2 go
  where
    go helpText rOpts = do
      result <- Docopt.run (Right helpText) (readCommonOpts rOpts)
      pure $ rawValue <$> result

-- |
-- | Run neodoc from JS, provided a spec.
-- |
runFromSpec :: forall e.
  Fn2 Foreign -- ^ The neodoc spec
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
runFromSpec = mkFn2 go
  where
    go rSpec rOpts = do
      case (readSpec rSpec) of
        Left e -> throwException (error (show e))
        Right spec -> do
          result <- Docopt.run (Left spec) (readCommonOpts rOpts)
          pure $ rawValue <$> result

-- | Interpret a foreign value as a JS dictionary
readObject :: Foreign -> F (StrMap Foreign)
readObject value | isObject value = pure $ unsafeFromForeign value
readObject value = Left (TypeMismatch "object" (typeOf value))

-- | Is this Foreign value an object?
isObject :: Foreign -> Boolean
isObject f = F.typeOf f == "object"

-- | Read common neodoc options
readCommonOpts :: Foreign -> Docopt.Options {}
readCommonOpts o = Docopt.defaultOptions {
    -- override argv with a custom array. Defaults to using `process.argv`
    argv = flip alt Docopt.defaultOptions.argv do
            toMaybe do
              F.readProp "argv" o

    -- override the environment with a custom hashmap. Defaults to using
    -- `process.env`
  , env = flip alt Docopt.defaultOptions.env do
            toMaybe do
              unsafeCoerce <$> do
                readObject =<< F.readProp "env" o

    -- enable "options-first" parsing. Options are only parsed and
    -- validated until the first operand (positional or command) is met.
    -- Trailing options are collected into a designated placeholder.
  , optionsFirst = either (const Docopt.defaultOptions.optionsFirst) id
                    (isTruthy <$> do
                      F.readProp "optionsFirst" o)

    -- enable "smart-options" parsing. This causes singleton groups that
    -- "look like" they are describing an option to expand to such an
    -- option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
  , smartOptions = either (const Docopt.defaultOptions.smartOptions) id
                    (isTruthy <$> do
                      F.readProp "smartOptions" o)

    -- stop parsing at these custom EOA markers. This allows any option
    -- to terminate a parse and collect all subsequent args.
  , stopAt = fromMaybe Docopt.defaultOptions.stopAt do
      toMaybe do
        p <- F.readProp "stopAt" o
        unsafeCoerce (F.readArray p) <|> do
          Array.singleton <$> F.readString p

    -- don't exit the process upon failure. By default, neodoc will
    -- exit the program if an error occured, right after printing the
    -- help text alongside an error message.
  , dontExit = either (const Docopt.defaultOptions.dontExit) id
                        (isTruthy <$> do
                          F.readProp "dontExit" o)
  }

-- |
-- | Parse the help-text and return the spec as a JS value
-- |
parse :: forall e.
        Fn2 String  -- ^ The neodoc help-text
            Foreign -- ^ The options (optional)
            (Eff (Docopt.DocoptEff e) ({
              specification :: Array (Array (Array Foreign))
            , shortHelp     :: String
            }))
parse = mkFn2 go
  where
    go helpText fOpts = do
      let
        opts
          = Docopt.defaultOptions {
              -- enable "smart-options" parsing. This causes singleton groups
              -- that "look like" they are describing an option to expand to
              -- such an option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
              smartOptions
                = either (const Docopt.defaultOptions.smartOptions) id
                         (isTruthy <$> do
                           F.readProp "smartOptions" fOpts)
            }

      { specification, shortHelp } <- Docopt.parse helpText opts

      let
        jsSpecification = toUnfoldable do
          specification <#> \branches -> do
            toUnfoldable do
              convBranch <$> branches

      pure {
        shortHelp:     shortHelp
      , specification: jsSpecification
      }

    convBranch :: Branch -> Array Foreign
    convBranch args = toUnfoldable $ convArg <$> args

    convArg :: Argument -> Foreign
    convArg (EOA)          = F.toForeign { type: "EOA" }
    convArg (Stdin)        = F.toForeign { type: "Stdin" }
    convArg (Command x)    = F.toForeign { type: "Command", value: x }
    convArg (Positional x) = F.toForeign { type: "Positional", value: x }
    convArg (Group x)      = F.toForeign {
      type: "Group"
    , value: {
        optional:   x.optional
      , repeatable: x.repeatable
      , branches:   (toUnfoldable $ convBranch <$> x.branches) :: Array (Array Foreign)
      }
    }
    convArg (Option x) = F.toForeign {
      type: "Option"
    , value: {
        flag:       maybe undefined F.toForeign x.flag
      , name:       maybe undefined F.toForeign x.name
      , env:        maybe undefined F.toForeign x.env
      , repeatable: x.repeatable
      , arg:        maybe undefined (\a -> {
                      name:     a.name
                    , default:  maybe undefined F.toForeign a.default
                    , optional: a.optional
                    }) x.arg
      }
    }

-- |
-- | Parse a foreign value into a specification
-- |
readSpec :: Foreign -> F Docopt
readSpec input = do
  shortHelp  <- F.readProp "shortHelp" input
  jsSpec     <- F.readProp "specification" input
  toplevel   <- F.readArray jsSpec
  spec       <- fromFoldable <$> do
    for toplevel \usage -> do
      branches <- F.readArray usage
      fromFoldable <$> do
        for branches \branch -> do
          args <- F.readArray branch
          fromFoldable <$> do
            for args readArg
  pure {
    shortHelp:     shortHelp
  , specification: spec
  }

  where
  readNode :: Foreign -> F (Tuple String (Maybe Foreign))
  readNode o = (/\) <$> (F.readString =<< F.readProp "type" o)
                    <*> ((Just <$> F.readProp "value" o) <|> pure Nothing)

  readArg :: Foreign -> F (Argument)
  readArg o = do
    n <- readNode o
    case n of
      "Group" /\ (Just v) -> do
        grp <$> (isTruthy <$> F.readProp "optional" v)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (fromFoldable <$> do
                  branches <- F.readArray =<< F.readProp "branches" v
                  for branches \branch -> do
                    args <- F.readArray branch
                    fromFoldable <$> do
                      for args readArg
                )
      "Command" /\ (Just v) -> do
        co <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Positional" /\ (Just v) -> do
        po <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Option" /\ (Just v) -> do
        opt <$> (ifHasProp v "flag" readFlag)
            <*> (ifHasProp v "name" readAsString)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (ifHasProp v "env" readAsString)
            <*> (readOptArg v)
      "Stdin" /\ _ -> pure Stdin
      "EOA"   /\ _ -> pure EOA
      x /\ _ -> Left (TypeMismatch "Group, Command, Positional, Option, Stdin or EOA" x)

  readOptArg :: Foreign -> F (Maybe OptionArgumentObj)
  readOptArg v = "option-argument" <?> do
    mx <- nullOrUndefined (F.readProp "arg" v)
    case mx of
      Nothing -> pure Nothing
      Just x  -> Just <$> do
          arg <$> (readAsString =<< F.readProp "name" x)
              <*> (ifHasProp x "default" \x ->
                      (BoolValue   <$> F.readBoolean x) <|>
                      (IntValue    <$> F.readInt     x) <|>
                      (FloatValue  <$> F.readNumber  x) <|>
                      (StringValue <$> F.readString  x)
                  )
              <*> (isTruthy <$> F.readProp "optional" x)

  readFlag :: Foreign -> F Char
  readFlag v = "flag. Must be a single character." <?> do
      s <- readAsString v
      F.readChar (F.toForeign s)

  grp x y z     = Group      { optional: x, repeatable: y, branches: z }
  co  x y       = Command    { name: x, repeatable: y }
  po  x y       = Positional { name: x, repeatable: y }
  opt a b c d e = Option     { flag: a, name: b, repeatable: c, env: d, arg: e }
  arg x y z     = { name: x, default: y, optional: z }

optional :: forall a. F a -> F (Maybe a)
optional x = (Just <$> x) <|> pure Nothing

ifHasProp :: forall a. Foreign -> String -> (Foreign -> F a) -> F (Maybe a)
ifHasProp v s f = do
  mv <- nullOrUndefined (F.readProp s v)
  case mv of
    Nothing -> pure Nothing
    Just  v -> Just <$> f v

toMaybe :: forall a b. Either a b -> Maybe b
toMaybe e = either (const Nothing) (pure <<< id) e

readAsString :: Foreign -> F String
readAsString v = do
  (             (F.unsafeReadTagged "String"  v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Boolean" v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Number"  v :: F String))

nullOrUndefined :: F Foreign -> F (Maybe Foreign)
nullOrUndefined x = F.unNullOrUndefined <$> do
  F.readNullOrUndefined pure =<< x

infixl 9 expected as <?>
expected :: forall a. String -> F a -> F a
expected msg x = lmap (\_ -> JSONError $ "Invalid " <> msg) x

foreign import undefined :: forall a. a
foreign import toString  :: forall a. a -> String

-- |
-- | Docopt FFI surface.
-- |
-- | Entrypoints to be called from JS-land.
-- | Data input and output is santized for either language and functions are
-- | curried/uncurried as needed.
-- |

module Docopt.FFI (
  run
, runFromSpec
, parse
, undefined
, readAsString
) where

import Prelude
import Debug.Trace
import Data.Function.Uncurried
import Data.Bifunctor (lmap)
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.List (toUnfoldable, List(Nil), fromFoldable)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Tuple (Tuple())
import Data.Tuple.Nested ((/\))
import Data.Array (singleton) as Array
import Data.Traversable (traverse, for)
import Control.Monad.Eff (Eff())
import Data.Either (Either(..), either)
import Data.StrMap (StrMap())
import Control.Bind ((=<<))
import Control.Alt (alt, (<|>))
import Data.String (toChar) as String
import Data.Foreign (readBoolean, readChar, readArray, readString, typeOf, toForeign,
                    readInt, readNumber, unsafeReadTagged) as F
import Data.Foreign (Foreign, F, ForeignError(..), typeOf, unsafeFromForeign,
                    toForeign)
import Data.Foreign.Class (readProp) as F
import Data.Foreign.NullOrUndefined as F
import Language.Docopt.Argument (Branch(), Argument(..), OptionArgumentObj)
import Unsafe.Coerce (unsafeCoerce)

import Docopt as Docopt
import Language.Docopt (Specification(), Docopt())
import Language.Docopt.Value (Value(..))

type RawValue = Unit

-- | Convert a Value into a JS-native value.
rawValue :: Value -> RawValue
rawValue (BoolValue   b) = unsafeCoerce b
rawValue (IntValue    i) = unsafeCoerce i
rawValue (FloatValue  x) = unsafeCoerce x
rawValue (StringValue s) = unsafeCoerce s
rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

foreign import isTruthy :: Foreign -> Boolean

-- |
-- | Run neodoc from JS.
-- |
run :: forall e.
  Fn2 String  -- ^ The neodoc text
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
run = mkFn2 go
  where
    go helpText rOpts = do
      result <- Docopt.run (Right helpText) (readCommonOpts rOpts)
      pure $ rawValue <$> result

-- |
-- | Run neodoc from JS, provided a spec.
-- |
runFromSpec :: forall e.
  Fn2 Foreign -- ^ The neodoc spec
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
runFromSpec = mkFn2 go
  where
    go rSpec rOpts = do
      case (readSpec rSpec) of
        Left e -> throwException (error (show e))
        Right spec -> do
          result <- Docopt.run (Left spec) (readCommonOpts rOpts)
          pure $ rawValue <$> result

-- | Interpret a foreign value as a JS dictionary
readObject :: Foreign -> F (StrMap Foreign)
readObject value | isObject value = pure $ unsafeFromForeign value
readObject value = Left (TypeMismatch "object" (typeOf value))

-- | Is this Foreign value an object?
isObject :: Foreign -> Boolean
isObject f = F.typeOf f == "object"

-- | Read common neodoc options
readCommonOpts :: Foreign -> Docopt.Options {}
readCommonOpts o = Docopt.defaultOptions {
    -- override argv with a custom array. Defaults to using `process.argv`
    argv = flip alt Docopt.defaultOptions.argv do
            toMaybe do
              F.readProp "argv" o

    -- override the environment with a custom hashmap. Defaults to using
    -- `process.env`
  , env = flip alt Docopt.defaultOptions.env do
            toMaybe do
              unsafeCoerce <$> do
                readObject =<< F.readProp "env" o

    -- enable "options-first" parsing. Options are only parsed and
    -- validated until the first operand (positional or command) is met.
    -- Trailing options are collected into a designated placeholder.
  , optionsFirst = either (const Docopt.defaultOptions.optionsFirst) id
                    (isTruthy <$> do
                      F.readProp "optionsFirst" o)

    -- enable "smart-options" parsing. This causes singleton groups that
    -- "look like" they are describing an option to expand to such an
    -- option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
  , smartOptions = either (const Docopt.defaultOptions.smartOptions) id
                    (isTruthy <$> do
                      F.readProp "smartOptions" o)

    -- stop parsing at these custom EOA markers. This allows any option
    -- to terminate a parse and collect all subsequent args.
  , stopAt = fromMaybe Docopt.defaultOptions.stopAt do
      toMaybe do
        p <- F.readProp "stopAt" o
        unsafeCoerce (F.readArray p) <|> do
          Array.singleton <$> F.readString p

    -- don't exit the process upon failure. By default, neodoc will
    -- exit the program if an error occured, right after printing the
    -- help text alongside an error message.
  , dontExit = either (const Docopt.defaultOptions.dontExit) id
                        (isTruthy <$> do
                          F.readProp "dontExit" o)
  }

-- |
-- | Parse the help-text and return the spec as a JS value
-- |
parse :: forall e.
        Fn2 String  -- ^ The neodoc help-text
            Foreign -- ^ The options (optional)
            (Eff (Docopt.DocoptEff e) ({
              specification :: Array (Array (Array Foreign))
            , shortHelp     :: String
            }))
parse = mkFn2 go
  where
    go helpText fOpts = do
      let
        opts
          = Docopt.defaultOptions {
              -- enable "smart-options" parsing. This causes singleton groups
              -- that "look like" they are describing an option to expand to
              -- such an option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
              smartOptions
                = either (const Docopt.defaultOptions.smartOptions) id
                         (isTruthy <$> do
                           F.readProp "smartOptions" fOpts)
            }

      { specification, shortHelp } <- Docopt.parse helpText opts

      let
        jsSpecification = toUnfoldable do
          specification <#> \branches -> do
            toUnfoldable do
              convBranch <$> branches

      pure {
        shortHelp:     shortHelp
      , specification: jsSpecification
      }

    convBranch :: Branch -> Array Foreign
    convBranch args = toUnfoldable $ convArg <$> args

    convArg :: Argument -> Foreign
    convArg (EOA)          = F.toForeign { type: "EOA" }
    convArg (Stdin)        = F.toForeign { type: "Stdin" }
    convArg (Command x)    = F.toForeign { type: "Command", value: x }
    convArg (Positional x) = F.toForeign { type: "Positional", value: x }
    convArg (Group x)      = F.toForeign {
      type: "Group"
    , value: {
        optional:   x.optional
      , repeatable: x.repeatable
      , branches:   (toUnfoldable $ convBranch <$> x.branches) :: Array (Array Foreign)
      }
    }
    convArg (Option x) = F.toForeign {
      type: "Option"
    , value: {
        flag:       maybe undefined F.toForeign x.flag
      , name:       maybe undefined F.toForeign x.name
      , env:        maybe undefined F.toForeign x.env
      , repeatable: x.repeatable
      , arg:        maybe undefined (\a -> {
                      name:     a.name
                    , default:  maybe undefined F.toForeign a.default
                    , optional: a.optional
                    }) x.arg
      }
    }

-- |
-- | Parse a foreign value into a specification
-- |
readSpec :: Foreign -> F Docopt
readSpec input = do
  shortHelp  <- F.readProp "shortHelp" input
  jsSpec     <- F.readProp "specification" input
  toplevel   <- F.readArray jsSpec
  spec       <- fromFoldable <$> do
    for toplevel \usage -> do
      branches <- F.readArray usage
      fromFoldable <$> do
        for branches \branch -> do
          args <- F.readArray branch
          fromFoldable <$> do
            for args readArg
  pure {
    shortHelp:     shortHelp
  , specification: spec
  }

  where
  readNode :: Foreign -> F (Tuple String (Maybe Foreign))
  readNode o = (/\) <$> (F.readString =<< F.readProp "type" o)
                    <*> ((Just <$> F.readProp "value" o) <|> pure Nothing)

  readArg :: Foreign -> F (Argument)
  readArg o = do
    n <- readNode o
    case n of
      "Group" /\ (Just v) -> do
        grp <$> (isTruthy <$> F.readProp "optional" v)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (fromFoldable <$> do
                  branches <- F.readArray =<< F.readProp "branches" v
                  for branches \branch -> do
                    args <- F.readArray branch
                    fromFoldable <$> do
                      for args readArg
                )
      "Command" /\ (Just v) -> do
        co <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Positional" /\ (Just v) -> do
        po <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Option" /\ (Just v) -> do
        opt <$> (ifHasProp v "flag" readFlag)
            <*> (ifHasProp v "name" readAsString)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (ifHasProp v "env" readAsString)
            <*> (readOptArg v)
      "Stdin" /\ _ -> pure Stdin
      "EOA"   /\ _ -> pure EOA
      x /\ _ -> Left (TypeMismatch "Group, Command, Positional, Option, Stdin or EOA" x)

  readOptArg :: Foreign -> F (Maybe OptionArgumentObj)
  readOptArg v = "invalid option-argument" <!?> do
    mx <- nullOrUndefined (F.readProp "arg" v)
    case mx of
      Nothing -> pure Nothing
      Just x  -> Just <$> do
          arg <$> (readAsString =<< F.readProp "name" x)
              <*> (ifHasProp x "default" \x ->
                      (BoolValue   <$> F.readBoolean x) <|>
                      (IntValue    <$> F.readInt     x) <|>
                      (FloatValue  <$> F.readNumber  x) <|>
                      (StringValue <$> F.readString  x)
                  )
              <*> (isTruthy <$> F.readProp "optional" x)

  readFlag :: Foreign -> F Char
  readFlag v = do
    s <- readAsString v
    F.readChar (F.toForeign s)

  grp x y z     = Group      { optional: x, repeatable: y, branches: z }
  co  x y       = Command    { name: x, repeatable: y }
  po  x y       = Positional { name: x, repeatable: y }
  opt a b c d e = Option     { flag: a, name: b, repeatable: c, env: d, arg: e }
  arg x y z     = { name: x, default: y, optional: z }

optional :: forall a. F a -> F (Maybe a)
optional x = (Just <$> x) <|> pure Nothing

ifHasProp :: forall a. Foreign -> String -> (Foreign -> F a) -> F (Maybe a)
ifHasProp v s f = do
  mv <- nullOrUndefined (F.readProp s v)
  case mv of
    Nothing -> pure Nothing
    Just  v -> Just <$> f v

toMaybe :: forall a b. Either a b -> Maybe b
toMaybe e = either (const Nothing) (pure <<< id) e

readAsString :: Foreign -> F String
readAsString v = do
  (             (F.unsafeReadTagged "String"  v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Boolean" v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Number"  v :: F String))

nullOrUndefined :: F Foreign -> F (Maybe Foreign)
nullOrUndefined x = F.unNullOrUndefined <$> do
  F.readNullOrUndefined pure =<< x

infixl 9 invalidMsg as <!?>
invalidMsg :: forall a. String -> F a -> F a
invalidMsg msg x = lmap (\e -> JSONError $ msg <> ": " <> show e) x

foreign import undefined :: forall a. a
foreign import toString  :: forall a. a -> String


Read numbers (and not) nicely and avoid NaN

module App.Account where

import Prelude (const, show, map, ($), id, (#))
import Pux.Html (Html, div, span, button, text, input, li, ul)
import Pux.Html.Events (onClick, onInput)
import Pux.Html.Attributes (placeholder, type_)
import Data.Array (deleteAt, modifyAt, mapWithIndex, snoc)
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Global (isNaN, readFloat)

data Action
  = UpdateAccount { name :: String
                  , initialValue :: Number }
  |UpdateIncomeEvent { eventNum :: Int
                     , name :: String
                     , change :: Number }
  | DeleteIncomeEvent Int
  | NewIncomeEvent

type IncomeEvent = { name :: String
                   , change :: Number }

updateIncomeEvent :: Int -> IncomeEvent -> Action
updateIncomeEvent eventNum { name: name, change: change } =
  UpdateIncomeEvent { eventNum: eventNum
                    , name: name
                    , change: change }

emptyIncomeEvent :: IncomeEvent
emptyIncomeEvent = { name: ""
                  , change: 0.0 }

type State = { name :: String
             , initialValue :: Number
             , incomeEvents :: Array IncomeEvent }

init :: State
init = { name: ""
       , initialValue: 0.0
       , incomeEvents: [(emptyIncomeEvent)] }

update :: Action -> State -> State
update NewIncomeEvent account =
  account { incomeEvents = account.incomeEvents `snoc` emptyIncomeEvent }
update (UpdateAccount { name: name, initialValue: initialValue }) account =
  account { name = name, initialValue = initialValue }
update (UpdateIncomeEvent { eventNum: eventNum, name: name, change: change}) account =
  account { incomeEvents = (fromMaybe account.incomeEvents
                                      (modifyAt eventNum (\_ -> newIncomeEvent) account.incomeEvents)) }
  where
    newIncomeEvent = { name: name, change: change}
update (DeleteIncomeEvent eventNum) account =
  account { incomeEvents = (fromMaybe account.incomeEvents
                                      (deleteAt eventNum account.incomeEvents)) }

readNumber :: String -> Number
readNumber numberText =
  if maybeNumber # isNaN then 0.0 else maybeNumber
  where
    maybeNumber = readFloat numberText

incomeEventInput :: IncomeEvent -> Html IncomeEvent
incomeEventInput incomeEvent =
  div
    []
    [ input [ type_ "text"
            , placeholder incomeEvent.name
            , onInput (\newName -> { name: newName.target.value, change: incomeEvent.change }) ]
            []
    , input [ type_ "number"
            , placeholder $ show incomeEvent.change
            , onInput (\change -> { name: incomeEvent.name
                                  , change: (readNumber change.target.value) }) ]
            []
    ]

incomeEventInputs :: Array IncomeEvent -> Html Action
incomeEventInputs incomeEvents =
  div
    []
    [ ul [] (mapWithIndex (\index incomeEvent ->
                          li
                            []
                            [ map (updateIncomeEvent index) $ (incomeEventInput incomeEvent)
                            , button [ onClick $ const $ DeleteIncomeEvent index ] [ text "-" ]
                            ])
                          incomeEvents)
    , button [ onClick (const NewIncomeEvent) ] [ text "New income event" ]
    ]

view :: State -> Html Action
view account =
  div
    []
    [ input [ type_ "text"
            , placeholder account.name
            , onInput (\newName -> UpdateAccount { name: newName.target.value
                                                 , initialValue: account.initialValue })
            ]
            []
    , input [ type_ "number"
            , placeholder $ show account.initialValue
            , onInput (\initialValue -> UpdateAccount { name: account.name
                                                      , initialValue: readNumber initialValue.target.value })
            ]
            []
    , incomeEventInputs account.incomeEvents
    ]

module App.Account where

import Prelude (const, show, map, ($), id)
import Pux.Html (Html, div, span, button, text, input, li, ul)
import Pux.Html.Events (onClick, onInput)
import Pux.Html.Attributes (placeholder, type_)
import Data.Array (deleteAt, modifyAt, mapWithIndex, snoc)
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Global (readFloat)

data Action
  = UpdateAccount { name :: String
                  , initialValue :: Number }
  |UpdateIncomeEvent { eventNum :: Int
                     , name :: String
                     , change :: Number }
  | DeleteIncomeEvent Int
  | NewIncomeEvent

type IncomeEvent = { name :: String
                   , change :: Number }

updateIncomeEvent :: Int -> IncomeEvent -> Action
updateIncomeEvent eventNum { name: name, change: change } =
  UpdateIncomeEvent { eventNum: eventNum
                    , name: name
                    , change: change }

emptyIncomeEvent :: IncomeEvent
emptyIncomeEvent = { name: ""
                  , change: 0.0 }

type State = { name :: String
             , initialValue :: Number
             , incomeEvents :: Array IncomeEvent }

init :: State
init = { name: ""
       , initialValue: 0.0
       , incomeEvents: [(emptyIncomeEvent)] }

update :: Action -> State -> State
update NewIncomeEvent account =
  account { incomeEvents = account.incomeEvents `snoc` emptyIncomeEvent }
update (UpdateAccount { name: name, initialValue: initialValue }) account =
  account { name = name, initialValue = initialValue }
update (UpdateIncomeEvent { eventNum: eventNum, name: name, change: change}) account =
  account { incomeEvents = (fromMaybe account.incomeEvents
                                      (modifyAt eventNum (\_ -> newIncomeEvent) account.incomeEvents)) }
  where
    newIncomeEvent = { name: name, change: change}
update (DeleteIncomeEvent eventNum) account =
  account { incomeEvents = (fromMaybe account.incomeEvents
                                      (deleteAt eventNum account.incomeEvents)) }

incomeEventInput :: IncomeEvent -> Html IncomeEvent
incomeEventInput incomeEvent =
  div
    []
    [ input [ type_ "text"
            , placeholder incomeEvent.name
            , onInput (\newName -> { name: newName.target.value, change: incomeEvent.change }) ]
            []
    , input [ type_ "number"
            , placeholder $ show incomeEvent.change
            , onInput (\change -> { name: incomeEvent.name
                                  , change: (readFloat change.target.value) }) ]
            []
    ]

incomeEventInputs :: Array IncomeEvent -> Html Action
incomeEventInputs incomeEvents =
  div
    []
    [ ul [] (mapWithIndex (\index incomeEvent ->
                          li
                            []
                            [ map (updateIncomeEvent index) $ (incomeEventInput incomeEvent)
                            , button [ onClick $ const $ DeleteIncomeEvent index ] [ text "-" ]
                            ])
                          incomeEvents)
    , button [ onClick (const NewIncomeEvent) ] [ text "New income event" ]
    ]

view :: State -> Html Action
view account =
  div
    []
    [ input [ type_ "text"
            , placeholder account.name
            , onInput (\newName -> UpdateAccount { name: newName.target.value
                                                 , initialValue: account.initialValue })
            ]
            []
    , input [ type_ "number"
            , placeholder $ show account.initialValue
            , onInput (\initialValue -> UpdateAccount { name: account.name
                                                      , initialValue: readFloat initialValue.target.value })
            ]
            []
    , incomeEventInputs account.incomeEvents
    ]