Add type information for divs representing bindings

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.Maybe (Maybe(..), maybe)
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.JQuery as J
import DOM (DOM)

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

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

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 t a)            = atom t a
    go hole expr@(List t ls)           = case toString ls of
                                           Nothing  -> list t (zipList go (hole <<< List Nothing) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] t
    go hole expr@(NTuple t ls)         = ntuple t (zipList go (hole <<< NTuple Nothing) ls) expr hole
    go hole expr@(Binary _ op_tup@(Tuple op t) e1 e2)   = binary t op
                                           (go (\e1 -> hole $ Binary Nothing op_tup e1 e2) e1)
                                           (go (\e2 -> hole $ Binary Nothing op_tup e1 e2) e2)
                                           expr hole
    go hole expr@(Unary t op e)        = unary t (unpackOp op) (go (hole <<< Unary Nothing op) e) expr hole
    go hole expr@(SectL t e op)        = sectl t (go (\e -> hole $ SectL Nothing e op) e) (unpackOp op) expr hole
    go hole expr@(SectR t op e)        = sectr t (unpackOp op) (go (hole <<< SectR Nothing op) e) expr hole
    go hole      (PrefixOp t op)       = prefixOp t (unpackOp op)
    go hole expr@(IfExpr t ce te ee)   = ifexpr t
                                           (go (\ce -> hole $ IfExpr Nothing ce te ee) ce)
                                           (go (\te -> hole $ IfExpr Nothing ce te ee) te)
                                           (go (\ee -> hole $ IfExpr Nothing ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr t bes body)  = letexpr t
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr Nothing xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr Nothing bes x) body)
                                           expr hole
    go hole expr@(Lambda t binds body) = lambda t (binding <$> binds) (go (hole <<< Lambda Nothing binds) body) expr hole

    go hole expr@(ArithmSeq t start next end)
                                       = arithmseq t
                                           (go (\x -> hole $ ArithmSeq Nothing x next end) start)
                                           (go (\x -> hole $ ArithmSeq Nothing start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq Nothing start next (Just x)) <$> end)
                                           expr hole

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

    go hole expr@(App t func args) = app t (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing 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 "<-" ["comma"] []

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

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 :: Tuple Op MType -> Op
unpackOp (Tuple op _) = op

opToDiv :: MType -> Op -> Div
opToDiv t op = typedNode (pPrintOp op) ["op"] [] t

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

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

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

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

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

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

prefixOp :: MType -> Op -> Div
prefixOp t op = node "" ["prefixOp"] [openBrace, opToDiv t op, closeBrace]

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"] []
    close = node "]" ["brace"] []
    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"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom t a] t
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) t
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) t
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) t

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

divToJQuery :: forall eff. Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  -- div <- makeDiv content ((maybe "untyped" prettyPrintType exprType) : classes)
  div <- makeDiv (maybe "_" (\t -> content <> " :: " <> prettyPrintType t)exprType) classes
  -- div <- makeDiv content classes
  for children (divToJQuery 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
  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 eff. String -> List Class -> Eff (dom :: DOM | 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.Maybe (Maybe(..), maybe)
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.JQuery as J
import DOM (DOM)

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

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

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 t a)            = atom t a
    go hole expr@(List t ls)           = case toString ls of
                                           Nothing  -> list t (zipList go (hole <<< List Nothing) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] t
    go hole expr@(NTuple t ls)         = ntuple t (zipList go (hole <<< NTuple Nothing) ls) expr hole
    go hole expr@(Binary _ op_tup@(Tuple op t) e1 e2)   = binary t op
                                           (go (\e1 -> hole $ Binary Nothing op_tup e1 e2) e1)
                                           (go (\e2 -> hole $ Binary Nothing op_tup e1 e2) e2)
                                           expr hole
    go hole expr@(Unary t op e)        = unary t (unpackOp op) (go (hole <<< Unary Nothing op) e) expr hole
    go hole expr@(SectL t e op)        = sectl t (go (\e -> hole $ SectL Nothing e op) e) (unpackOp op) expr hole
    go hole expr@(SectR t op e)        = sectr t (unpackOp op) (go (hole <<< SectR Nothing op) e) expr hole
    go hole      (PrefixOp t op)       = prefixOp t (unpackOp op)
    go hole expr@(IfExpr t ce te ee)   = ifexpr t
                                           (go (\ce -> hole $ IfExpr Nothing ce te ee) ce)
                                           (go (\te -> hole $ IfExpr Nothing ce te ee) te)
                                           (go (\ee -> hole $ IfExpr Nothing ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr t bes body)  = letexpr t
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr Nothing xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr Nothing bes x) body)
                                           expr hole
    go hole expr@(Lambda t binds body) = lambda t (binding <$> binds) (go (hole <<< Lambda Nothing binds) body) expr hole

    go hole expr@(ArithmSeq t start next end)
                                       = arithmseq t
                                           (go (\x -> hole $ ArithmSeq Nothing x next end) start)
                                           (go (\x -> hole $ ArithmSeq Nothing start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq Nothing start next (Just x)) <$> end)
                                           expr hole

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

    go hole expr@(App t func args) = app t (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing 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 "<-" ["comma"] []

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

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 :: Tuple Op MType -> Op
unpackOp (Tuple op _) = op

opToDiv :: MType -> Op -> Div
opToDiv t op = typedNode (pPrintOp op) ["op"] [] t

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

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

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

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

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

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

prefixOp :: MType -> Op -> Div
prefixOp t op = node "" ["prefixOp"] [openBrace, opToDiv t op, closeBrace]

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"] []
    close = node "]" ["brace"] []
    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"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = node "" ["binding", "lit"] [atom t a]
binding (ConsLit _ b1 b2) = node "" ["binding", "conslit"] $ listify "(" ":" ")" (Cons (binding b1) (Cons (binding b2) Nil))
binding (ListLit _ ls)    = node "" ["binding", "listlit"] $ listify "[" "," "]" (binding <$> ls)
binding (NTupleLit _ ls)   = node "" ["binding", "tuplelit"] $ listify "(" "," ")" (binding <$> ls)

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

divToJQuery :: forall eff. Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  div <- makeDiv content classes
  for children (divToJQuery 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
  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 eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

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


Parsing commands #15

Parsing commands #15

module Interactive where

import Data.Tuple
import Data.Either
import Data.String (joinWith, indexOf, drop)

import Debug.Trace

import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Process
import Control.Monad.Eff.FS

import Node.Args
import Node.ReadLine

import Language.PureScript.Names
import Language.PureScript.Declarations (Value())

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

-- |
-- Valid Meta-commands for PSCI
--
data Command
  -- |
  -- A purescript expression
  --
  = Eval Value
  -- |
  -- Show the help command
  --
  | Help
  -- |
  -- Import a module from a loaded file
  --
  | Import ModuleName
  -- |
  -- Load a file for use with importing
  --
  | LoadFile String
  -- |
  -- Exit PSCI
  --
  | Quit
  -- |
  -- Reset the state of the REPL
  --
  | Reset
  -- |
  -- Binds a value to a name
  --
  | Let (Value -> Value)
  -- |
  -- Find the type of an expression
  --
  | TypeOf Value

parse :: forall a. P.Parser P.TokenStream a -> String -> Either String a
parse p s = P.lex s >>= P.runTokenParser (p <* P.eof)

parseLet :: P.Parser P.TokenStream Command
parseLet = Let <$> (Language.PureScript.Declarations.Let <$> (P.reserved "let" *> P.braces (P.many1 P.parseDeclaration)))

parseCommand :: String -> Either String Command
parseCommand ":?" = Right Help
parseCommand ":q" = Right Quit
parseCommand ":r" = Right Reset
parseCommand cmd | indexOf ":i " cmd == 0 = Import <$> parse P.moduleName (drop 3 cmd)
parseCommand cmd | indexOf ":m " cmd == 0 = Right $ LoadFile (drop 3 cmd)
parseCommand cmd | indexOf ":t " cmd == 0 = TypeOf <$> parse (P.parseValue {}) (drop 3 cmd)
parseCommand cmd | indexOf ":" cmd == 0 = Left "Unknown command. Type :? for help."
parseCommand cmd = parse (parseLet <|> (Eval <$> P.parseValue {})) cmd

-- |
-- The help menu.
--
help :: String
help =
  "  :?            Show this help menu\n\
  \  :i <module>   Import <module> for use in PSCi\n\
  \  :m <file>     Load <file> for importing\n\
  \  :q            Quit PSCi\n\
  \  :r            Reset\n\
  \  :t <expr>     Show the type of <expr>"

prologueMessage :: String
prologueMessage =
  " ____                 ____            _       _   \n\
  \|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ \n\
  \| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|\n\
  \|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ \n\
  \|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|\n\
  \                                       |_|        \n\
  \\n\
  \:? shows help\n\
  \\n\
  \Expressions are terminated using Ctrl+D"

completion :: forall eff. Completer eff
completion s = return $ Tuple [] s

handleCommand :: Command -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
handleCommand Help = trace help
handleCommand Quit = trace "See ya!" *> exit 0
handleCommand cmd = return {}

lineHandler :: String -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
lineHandler input =
  case parseCommand input of
    Left msg -> trace msg
    Right cmd -> handleCommand cmd

loop :: [String] -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
loop inputFiles = do
  interface <- createInterface process.stdin process.stdout completion
  setPrompt "> " 2 interface
  prompt interface
  setLineHandler (\s -> lineHandler s <* prompt interface) interface
  return {}

inputFiles :: Args [String]
inputFiles = many argOnly

term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {})
term = loop <$> inputFiles

main = do
  trace prologueMessage
  result <- readArgs' term
  case result of
    Left err -> print err
    _ -> return {}

module Interactive where

import Data.Tuple
import Data.Either
import Data.String (joinWith, indexOf, drop)

import Debug.Trace

import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Process
import Control.Monad.Eff.FS

import Node.Args
import Node.ReadLine

import Text.Parsing.Parser

import Language.PureScript.Names
import Language.PureScript.Declarations (Value())

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

-- |
-- Valid Meta-commands for PSCI
--
data Command
  -- |
  -- A purescript expression
  --
  = Eval Value
  -- |
  -- Show the help command
  --
  | Help
  -- |
  -- Import a module from a loaded file
  --
  | Import ModuleName
  -- |
  -- Load a file for use with importing
  --
  | LoadFile String
  -- |
  -- Exit PSCI
  --
  | Quit
  -- |
  -- Reset the state of the REPL
  --
  | Reset
  -- |
  -- Binds a value to a name
  --
  | Let (Value -> Value)
  -- |
  -- Find the type of an expression
  --
  | TypeOf Value

parse :: forall a. Parser P.TokenStream a -> String -> Either String a
parse p s = P.lex s >>= P.runTokenParser (p <* P.eof)

parseCommand :: String -> Either String Command
parseCommand ":?" = Right Help
parseCommand ":q" = Right Quit
parseCommand ":r" = Right Reset
parseCommand cmd | indexOf ":i " cmd == 0 = Import <$> parse P.moduleName (drop 3 cmd)
parseCommand cmd | indexOf ":m " cmd == 0 = Right $ LoadFile (drop 3 cmd)
parseCommand cmd | indexOf ":t " cmd == 0 = TypeOf <$> parse (P.parseValue {}) (drop 3 cmd)
parseCommand cmd | indexOf ":" cmd == 0 = Left "Unknown command. Type :? for help."

-- |
-- The help menu.
--
help :: String
help =
  "  :?            Show this help menu\n\
  \  :i <module>   Import <module> for use in PSCi\n\
  \  :m <file>     Load <file> for importing\n\
  \  :q            Quit PSCi\n\
  \  :r            Reset\n\
  \  :t <expr>     Show the type of <expr>"

prologueMessage :: String
prologueMessage =
  " ____                 ____            _       _   \n\
  \|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ \n\
  \| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|\n\
  \|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ \n\
  \|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|\n\
  \                                       |_|        \n\
  \\n\
  \:? shows help\n\
  \\n\
  \Expressions are terminated using Ctrl+D"

completion :: forall eff. Completer eff
completion s = return $ Tuple [] s

handleCommand :: Command -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
handleCommand Help = trace help
handleCommand Quit = trace "See ya!" *> exit 0
handleCommand cmd = return {}

lineHandler :: String -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
lineHandler input =
  case parseCommand input of
    Left msg -> trace msg
    Right cmd -> handleCommand cmd

loop :: [String] -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {}
loop inputFiles = do
  interface <- createInterface process.stdin process.stdout completion
  setPrompt "> " 2 interface
  prompt interface
  setLineHandler (\s -> lineHandler s <* prompt interface) interface
  return {}

inputFiles :: Args [String]
inputFiles = many argOnly

term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console) {})
term = loop <$> inputFiles

main = do
  trace prologueMessage
  result <- readArgs' term
  case result of
    Left err -> print err
    _ -> return {}


Turns out negative darkness is light

Turns out negative darkness is light

module Util.DOM where

import Color (toHexString, darken)
import Control.Monad.Eff (Eff)
import Data.Array (length)
import DOM (DOM)
import DOM.Classy.Element (toElement)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument, HTMLAnchorElement, HTMLUListElement)
import DOM.HTML.Window (document)
import DOM.Node.Document (createDocumentFragment, createElement)
import DOM.Node.Element (setAttribute, removeAttribute, setClassName)
import DOM.Node.Node (firstChild, removeChild, appendChild, setTextContent)
import DOM.Node.Types (Document, elementToNode, Node, documentFragmentToNode)
import Data.Maybe (Maybe(..))
import Data.Traversable (for)
import Data.Argonaut (encodeJson)
import Prelude (Unit, unit, show, (<$>), bind, pure, discard, (<<<), (<>), (>>=), ($), (==))
import Global (encodeURIComponent)
import Util.Color (isLight)
import Util.Types (Color'(..))

--------------------------------------------------------------------------------

isEmpty :: forall a. Array a -> Boolean
isEmpty xs = length xs == 0

--------------------------------------------------------------------------------

removeChildren :: forall eff. Node -> Eff (dom :: DOM | eff) Node
removeChildren parentNode = do
  maybeFirstChild <- firstChild parentNode
  case maybeFirstChild of
    Nothing        -> pure parentNode
    Just childNode -> do
      _ <- removeChild childNode parentNode
      removeChildren parentNode

--------------------------------------------------------------------------------

updatePalette :: forall eff. HTMLUListElement
                          -> Array Color'
                          -> Eff (dom :: DOM | eff) Unit
updatePalette ul colors = do
  _ <- removeChildren ulNode

  if isEmpty colors then do
      doc <- htmlDocumentToDocument <$> (window >>= document)
      li  <- createElement "li" doc

      let liNode = elementToNode li

      setClassName "preview__item preview__item--empty" li
      setTextContent "Maybe try one hexcode per line?" liNode

      _ <- appendChild liNode ulNode

      pure unit

    else do
      colorListFragNode <- createColorListFragNode colors
      _ <- appendChild colorListFragNode ulNode
      pure unit

  where
    ulNode = (elementToNode <<< toElement) ul

--------------------------------------------------------------------------------

updateDownloadLink :: forall eff. HTMLAnchorElement
                               -> Array Color'
                               -> Eff (dom :: DOM | eff) Unit
updateDownloadLink a colors = if isEmpty colors
  then do
    setAttribute "disabled" "disabled" aElement
    pure unit
  else do
    removeAttribute "disabled" aElement
    setAttribute "href" href aElement
    setAttribute "download" "custom.sketchpalette" aElement
    pure unit
  where
    href     = "data:text/json;charset=utf-8," <> encodeURIComponent sketchPalette
    aElement = toElement a
    sketchPalette = (show <<< encodeJson) colors

--------------------------------------------------------------------------------

appendPreviewSwatchItem :: forall eff. Document
                                    -> Node
                                    -> Color'
                                    -> Eff (dom :: DOM | eff) Node
appendPreviewSwatchItem doc fragNode (Color' c) = do

  li <- createElement "li" doc

  let liNode    = elementToNode li
      bgHex     = toHexString c
      bdrHex    = (toHexString <<< darken 0.5) c
      style     = "background-color:" <> bgHex <> ";" <> "border-color:" <> bdrHex <> ";"
      className = if isLight c
                  then "preview__item preview__item--light"
                  else "preview__item preview__item--dark"

  setAttribute "style" style li
  setAttribute "title" bgHex li
  setClassName className li

  _ <- appendChild liNode fragNode

  pure fragNode

--------------------------------------------------------------------------------

createColorListFragNode :: forall eff. Array Color'
                        -> Eff (dom :: DOM | eff) Node
createColorListFragNode colors = do

  doc      <- htmlDocumentToDocument <$> (window >>= document)
  fragNode <- documentFragmentToNode <$> createDocumentFragment doc
  _        <- for colors $ appendPreviewSwatchItem doc fragNode

  pure fragNode

--------------------------------------------------------------------------------

module Util.DOM where

import Color (toHexString, darken)
import Control.Monad.Eff (Eff)
import Data.Array (length)
import DOM (DOM)
import DOM.Classy.Element (toElement)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument, HTMLAnchorElement, HTMLUListElement)
import DOM.HTML.Window (document)
import DOM.Node.Document (createDocumentFragment, createElement)
import DOM.Node.Element (setAttribute, removeAttribute, setClassName)
import DOM.Node.Node (firstChild, removeChild, appendChild, setTextContent)
import DOM.Node.Types (Document, elementToNode, Node, documentFragmentToNode)
import Data.Maybe (Maybe(..))
import Data.Traversable (for)
import Data.Argonaut (encodeJson)
import Prelude (Unit, unit, show, negate, (<$>), bind, pure, discard, (<<<), (<>), (>>=), ($), (==))
import Global (encodeURIComponent)
import Util.Color (isLight)
import Util.Types (Color'(..))

--------------------------------------------------------------------------------

isEmpty :: forall a. Array a -> Boolean
isEmpty xs = length xs == 0

--------------------------------------------------------------------------------

removeChildren :: forall eff. Node -> Eff (dom :: DOM | eff) Node
removeChildren parentNode = do
  maybeFirstChild <- firstChild parentNode
  case maybeFirstChild of
    Nothing        -> pure parentNode
    Just childNode -> do
      _ <- removeChild childNode parentNode
      removeChildren parentNode

--------------------------------------------------------------------------------

updatePalette :: forall eff. HTMLUListElement
                          -> Array Color'
                          -> Eff (dom :: DOM | eff) Unit
updatePalette ul colors = do
  _ <- removeChildren ulNode

  if isEmpty colors then do
      doc <- htmlDocumentToDocument <$> (window >>= document)
      li  <- createElement "li" doc

      let liNode = elementToNode li

      setClassName "preview__item preview__item--empty" li
      setTextContent "Maybe try one hexcode per line?" liNode

      _ <- appendChild liNode ulNode

      pure unit

    else do
      colorListFragNode <- createColorListFragNode colors
      _ <- appendChild colorListFragNode ulNode
      pure unit

  where
    ulNode = (elementToNode <<< toElement) ul

--------------------------------------------------------------------------------

updateDownloadLink :: forall eff. HTMLAnchorElement
                               -> Array Color'
                               -> Eff (dom :: DOM | eff) Unit
updateDownloadLink a colors = if isEmpty colors
  then do
    setAttribute "disabled" "disabled" aElement
    pure unit
  else do
    removeAttribute "disabled" aElement
    setAttribute "href" href aElement
    setAttribute "download" "custom.sketchpalette" aElement
    pure unit
  where
    href     = "data:text/json;charset=utf-8," <> encodeURIComponent sketchPalette
    aElement = toElement a
    sketchPalette = (show <<< encodeJson) colors

--------------------------------------------------------------------------------

appendPreviewSwatchItem :: forall eff. Document
                                    -> Node
                                    -> Color'
                                    -> Eff (dom :: DOM | eff) Node
appendPreviewSwatchItem doc fragNode (Color' c) = do

  li <- createElement "li" doc

  let liNode    = elementToNode li
      bgHex     = toHexString c
      bdrHex    = (toHexString <<< darken (negate 0.5)) c
      style     = "background-color:" <> bgHex <> ";" <> "border-color:" <> bdrHex <> ";"
      className = if isLight c
                  then "preview__item preview__item--light"
                  else "preview__item preview__item--dark"

  setAttribute "style" style li
  setAttribute "title" bgHex li
  setClassName className li

  _ <- appendChild liNode fragNode

  pure fragNode

--------------------------------------------------------------------------------

createColorListFragNode :: forall eff. Array Color'
                        -> Eff (dom :: DOM | eff) Node
createColorListFragNode colors = do

  doc      <- htmlDocumentToDocument <$> (window >>= document)
  fragNode <- documentFragmentToNode <$> createDocumentFragment doc
  _        <- for colors $ appendPreviewSwatchItem doc fragNode

  pure fragNode

--------------------------------------------------------------------------------


Fixed issue with showing too few answers

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, filter, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
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 Pux.DOM.HTML.Attributes (key)
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, next :: Countries, current :: Countries, correct :: Int, incorrect :: Int }
type Countries = Array Country

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

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

derive instance newtypeCountry :: Newtype Country _
derive instance eqCountry :: Eq 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: [], next: [], current: [], correct: 0, incorrect: 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 Countries)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff $ pick countries 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 -> Countries -> Eff (random :: RANDOM | e) Countries
pick all current = pure <=< shuffle <<< (_ <> [next]) <<< take (answerCount - 1) <<<
                   filter (_ /= next) <=< shuffle $ all
  where next = maybe (Country { name: "_", flag: "_" }) id $ head current

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

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.next) <> "/" <> show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.next), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ (_.name <<< unwrap <$> state.current) $ \name ->
        li ! key name #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ 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, nub, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
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 :: Int, incorrect :: Int }
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, incorrect: 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 <<< nub <<< (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 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1 },
  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, incorrect = 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 state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (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 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ state.correct + state.incorrect) * 100.0


Field names are not the same as type names

Original commit 57a2ef6a497e4793405418b6f7eda85b053f2699

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (mapM, removeElement)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        }
    }

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

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

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

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("F_" <> str)

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: Doc Unit
golangDoc = do
    line """// To parse and unparse this JSON data, add this code to your project and do:
//
//    r, err := UnmarshalRoot(bytes)
//    bytes, err = r.Marshal()

package main
"""
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    { rendered: renderedToplevel, comment: toplevelComment } <- getTopLevel >>= renderTypeToGolang
    line $ "type Root " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line """func UnmarshalRoot(data []byte) (Root, error) {
	var r Root
	err := json.Unmarshal(data, &r)
	return r, err
}

func (r *Root) Marshal() ([]byte, error) {
	return json.Marshal(r)
}
"""
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    let propsArray = Map.toUnfoldable properties :: List _
    columns <- propsArray # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    columns <- (L.fromFoldable nonNullTypes) # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (mapM, removeElement)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        }
    }

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

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

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

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("F_" <> str)

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: Doc Unit
golangDoc = do
    line """// To parse and unparse this JSON data, add this code to your project and do:
//
//    r, err := UnmarshalRoot(bytes)
//    bytes, err = r.Marshal()

package main
"""
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    { rendered: renderedToplevel, comment: toplevelComment } <- getTopLevel >>= renderTypeToGolang
    line $ "type Root " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line """func UnmarshalRoot(data []byte) (Root, error) {
	var r Root
	err := json.Unmarshal(data, &r)
	return r, err
}

func (r *Root) Marshal() ([]byte, error) {
	return json.Marshal(r)
}
"""
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    let propsArray = Map.toUnfoldable properties :: List _
    columns <- propsArray # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    columns <- (L.fromFoldable nonNullTypes) # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \name -> do
            line $ "var c " <> name
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    f name
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p


completely review parser grammar and implementation, now perform a proper descent

module Ifrit.Parser where

import Prelude

import Control.Monad.State(StateT, get, lift, put)
import Data.Array(intercalate)
import Data.Decimal(Decimal, toString)
import Data.Either(Either(..))
import Data.List(List(..), (:))
import Data.Maybe(Maybe(..), maybe)

import Ifrit.Lexer as Lexer

type Parser expr = StateT (List Lexer.Token) (Either String) expr

class Parse expr where
  parse :: Parser expr

data Clause
  = Select Selector (Maybe Clause) (Maybe Condition) (Maybe Index)

data Selector
  = Single String (Maybe String)
  | Multiple (List Selector)
  | Function Lexer.Funktion String (Maybe String)

data Condition
  = Term Term
  | Or Term Term

data Term
  = Factor Factor
  | And Factor Factor

data Factor
  = Operand Operand
  | Binary Lexer.Binary Operand Operand

data Operand
  = String String
  | Boolean Boolean
  | Number Decimal
  | Field String
  | Null
  | Condition Condition

data Index
  = IdxField String
  | IdxNull

-- INSTANCE PARSE
instance parseIndex :: Parse Index where
  parse = do
    tokens <- get
    case tokens of
      Nil ->
      lift $ Left "parsing error (GROUP BY Index): incomplete expression"

      (Lexer.Word s : q) -> do
        put q
        pure $ IdxField s

      (Lexer.Keyword Lexer.Null : q) -> do
        put q
        pure $ IdxNull

      (Lexer.Parenthesis Lexer.Open : q) -> do
        put q
        index :: Index <- parse
        tokens' <- get
        case tokens' of
          (Lexer.Parenthesis Lexer.Close : q') -> do
            put q'
            pure $ index
          _ ->
            lift $ Left "parsing error (GROUP BY Index): unbalanced parenthesis expression"

      (h : _) ->
        lift $ Left $ "parsing error (GROUP BY Index): unexpected token: " <> show h

instance parseOperand :: Parse Operand where
  parse = do
    tokens <- get
    case tokens of
      Nil ->
        lift $ Left "parsing error (WHERE Operand): incomplete expression"

      (Lexer.String s : q) -> do
        put q
        pure $ String s

      (Lexer.Boolean b : q) -> do
        put q
        pure $ Boolean b

      (Lexer.Number n : q) -> do
        put q
        pure $ Number n

      (Lexer.Keyword Lexer.Null : q) -> do
        put q
        pure $ Null

      (Lexer.Word s : q) -> do
        put q
        pure $ Field s

      (Lexer.Parenthesis Lexer.Open : q) -> do
        put q
        condition :: Condition <- parse
        tokens' <- get
        case tokens' of
          (Lexer.Parenthesis Lexer.Close : q') -> do
            put q'
            pure $ Condition condition
          _ ->
            lift $ Left "parsing error (WHERE Operand): unbalanced parenthesis expression"

      (h : _) ->
        lift $ Left $ "parsing error (WHERE Operand): unexpected token: " <> show h

instance parseFactor :: Parse Factor where
  parse = do
    left :: Operand <- parse
    tokens <- get
    case tokens of
      (Lexer.Binary op : q) -> do
        put q
        right :: Operand <- parse
        pure $ Binary op left right

      _ ->
        pure $ Operand left

instance parseTerm :: Parse Term where
  parse = do
    left :: Factor <- parse
    tokens <- get
    case tokens of
      (Lexer.Keyword Lexer.And : q) -> do
        put q
        right :: Factor <- parse
        pure $ And left right

      _ ->
        pure $ Factor left

instance parseCondition :: Parse Condition where
  parse = do
    left :: Term <- parse
    tokens <- get
    case tokens of
      (Lexer.Keyword Lexer.Or : q) -> do
        put q
        right :: Term <- parse
        pure $ Or left right

      _ ->
        pure $ Term left

nextSelector :: String -> Maybe String -> List Lexer.Token -> Parser Selector
nextSelector w as q = do
  put q
  selector :: Selector <- parse
  case selector of
    Single _ _ ->
      pure $ Multiple $ (Single w as) : selector : Nil
    Function _ _ _ ->
      pure $ Multiple $ (Single w as) : selector : Nil
    Multiple xs ->
      pure $ Multiple $ (Single w as) : xs

instance parseSelector :: Parse Selector where
  parse = do
    tokens <- get
    case tokens of
      Nil ->
        lift $ Left "parsing error (SELECT Selector): incomplete expression"

      (Lexer.Alias w as : Lexer.Comma : q) -> do
        nextSelector w (Just as) q

      (Lexer.Alias w as : q) -> do
        put q
        pure $ Single w (Just as)

      (Lexer.Word w : Lexer.Comma : q) ->
        nextSelector w Nothing q

      (Lexer.Word w : q) -> do
        put q
        pure $ Single w Nothing

      (Lexer.Function f : q) -> do
        put q
        selector :: Selector <- parse
        case selector of
          Single w _ -> do
            tokens' <- get
            case tokens' of
              (Lexer.Keyword Lexer.As : Lexer.Word as : q') -> do
                put q'
                pure $ Function f w (Just as)
              _ ->
                pure $ Function f w Nothing

          _ ->
            lift $ Left $ "parsing error (SELECT Function): invalid argument for function " <> show f

      (Lexer.Parenthesis Lexer.Open : q) -> do
        put q
        selector :: Selector <- parse
        tokens' <- get
        case tokens' of
          (Lexer.Parenthesis Lexer.Close : q') -> do
            put q'
            pure $ selector

          _ ->
            lift $ Left "parsing error (SELECT Selector): unbalanced parenthesis expression"

      (h : _) ->
        lift $ Left $ "parsing error (SELECT Selector): unexpected token: " <> show h

maybeParse :: forall a. Parse a => Lexer.Keyword -> Parser (Maybe a)
maybeParse key = do
  tokens <- get
  case tokens of
    (Lexer.Keyword key' : q') | key' == key -> do
      put q'
      res <- parse
      pure $ Just res
    _ ->
      pure $ Nothing

instance parseClause :: Parse Clause where
  parse = do
    tokens <- get
    case tokens of
      Nil ->
        lift $ Left "parsing error (SELECT): incomplete expression"

      (Lexer.Keyword Lexer.Select : q) -> do
        put q
        selector :: Selector <- parse
        clause :: Maybe Clause <- maybeParse Lexer.From
        condition :: Maybe Condition <- maybeParse Lexer.Where
        index :: Maybe Index <- maybeParse Lexer.GroupBy
        pure $ Select selector clause condition index

      (Lexer.Parenthesis Lexer.Open : q) -> do
        put q
        clause :: Clause <- parse
        tokens' <- get
        case tokens' of
          (Lexer.Parenthesis Lexer.Close : q') -> do
            put q'
            pure clause

          _ ->
            lift $ Left "parsing error (SELECT Selector): unbalanced parenthesis expression"

      (h : _) ->
        lift $ Left $ "parsing error (SELECT): unexpected token: " <> show h

-- INSTANCE SHOW
instance showClause :: Show Clause where
  show (Select selectors clause condition index) =
    let
        clause' = maybe "" (\x -> " FROM (" <> (show x) <> ")") clause
        condition' = maybe "" (\x -> " WHERE (" <> (show x) <> ")") condition
        index' = maybe "" (\x -> " GROUP BY " <> (show x)) index
    in
        "SELECT " <> (show selectors)
        <> clause'
        <> condition'
        <> index'

instance showSelector :: Show Selector where
  show (Single s Nothing) =
    s
  show (Single s (Just as)) =
    "(" <> s <> " AS " <> as <> ")"
  show (Function f s Nothing) =
    show f <> "(" <> s <> ")"
  show (Function f s (Just as)) =
    "(" <> show f <> "(" <> s <> ")" <> " AS " <> ")"
  show (Multiple xs) =
    intercalate ", " (map show xs)

instance showCondition :: Show Condition where
  show (Term x) =
    show x
  show (Or a b) =
    show a <> " OR " <> show b

instance showTerm :: Show Term where
  show (Factor x) =
    show x
  show (And a b) =
    show a <> " AND " <> show b

instance showFactor :: Show Factor where
  show (Operand x) =
    show x
  show (Binary op a b) =
    show a <> " " <> show op <> " " <> show b

instance showOperand :: Show Operand where
  show (String x) =
    "\"" <> x <> "\""
  show (Boolean x) =
    show x
  show (Number x) =
    toString x
  show (Field x) =
    x
  show Null =
    "NULL"
  show (Condition x) =
    "(" <> show x <> ")"

instance showIndex :: Show Index where
  show (IdxField x) =
    x
  show (IdxNull) =
    "NULL"

module Ifrit.Parser where

import Prelude

import Control.Alt((<|>))
import Control.Monad.State(StateT, State, put, get, lift)
import Data.Array(fromFoldable, intercalate)
import Data.Either(Either(..))
import Data.List(List(..), (:), snoc)
import Data.Maybe(Maybe(..), maybe)
import Data.Tuple(Tuple(..), fst, snd)

import Ifrit.Lexer(Token(..))
import Ifrit.Lexer(Keyword(..)) as K
import Ifrit.Lexer(BooleanOp(..)) as O
import Ifrit.Lexer(Parenthesis(..)) as P
import Ifrit.Core(JsonSchema(..))

data Query
  = Select (List Selector) (Maybe Query) (Maybe Filter) (Maybe Group)

data Filter
  = Where Condition

data Group
  = GroupBy Operand

data Selector
  = Field String
  | FieldAs String String
  | Function Func String String

data Func
  = Avg
  | Count
  | Max
  | Min
  | Sum

data Condition
  = ConditionTerm Operator
  | And Condition Condition
  | Or Condition Condition

data Operator
  = Eq Operand Operand
  | Neq Operand Operand
  | Gt Operand Operand
  | Lt Operand Operand

data Operand
  = OpString String
  | OpBoolean Boolean
  | OpNumber Number
  | OpNull
  | OpSelector Selector

type Clause a = StateT (Tuple JsonSchema (List Token)) (Either String) a

unwrap :: List Token -> Either String (List Token)
unwrap tokens =
  let
      unwrap' 0 k (Parenthesis P.Open : q) Nil =
        unwrap' 0 (k + 1) q Nil
      unwrap' n k (Parenthesis P.Open : q) xs =
        unwrap' (n + 1) k q (snoc xs (Parenthesis P.Open))

      unwrap' 0 1 (Parenthesis P.Close : q) xs =
        Right (xs <|> q)
      unwrap' 0 k (Parenthesis P.Close : q) xs | k > 0 =
        unwrap' 0 (k - 1) q xs
      unwrap' n k (Parenthesis P.Close : q) xs | n > 0 =
        unwrap' (n - 1) k q (snoc xs (Parenthesis P.Close))

      unwrap' n k (h : q) xs =
        unwrap' n k q (snoc xs h)

      unwrap' 0 0 Nil xs =
        Right xs
      unwrap' _ _ Nil Nil =
        Right Nil
      unwrap' _ _ Nil xs =
        Left "parsing error: unbalanced parenthesis expression"
   in
      unwrap' 0 0 tokens Nil

parse :: Clause Query
parse = do
  Tuple schema tokens <- get
  case unwrap tokens of
    Right (Keyword K.Select : q) -> do
      case unwrap q of
        Left err ->
          lift $ Left err
        Right q' -> do
          put $ Tuple schema (Comma : q')
          selectors <- parseSelectors
          query <- parseFrom
          filter <- parseWhere
          pure $ Select selectors query filter Nothing

    Right (token:q) ->
      lift $ Left ("parsing error: invalid token: " <> (show token))

    Right Nil ->
      lift $ Left "parsing error: empty query"

    Left err ->
      lift $ Left err

parseSelectors :: Clause (List Selector)
parseSelectors = do
  Tuple schema tokens <- get
  case unwrap tokens of
    Right (Comma : (Word w) : (Keyword K.As) : (Word w') : q) -> do
      put $ Tuple schema q
      selectors <- parseSelectors
      pure $ (FieldAs w w') : selectors

    Right (Comma : (Word w) : q) -> do
      put $ Tuple schema q
      selectors <- parseSelectors
      pure $ (Field w) : selectors

    Right (Comma : q) -> do
      put $ Tuple schema q
      pure Nil

    Right _ ->
      pure Nil

    Left err ->
      lift $ Left err

parseFrom :: Clause (Maybe Query)
parseFrom = do
  Tuple schema tokens <- get
  case unwrap tokens of
    Right (Keyword K.From : Parenthesis P.Open : q) -> do
      put $ Tuple schema q
      query <- parse
      Tuple schema' tokens' <- get
      case tokens' of
        (Parenthesis P.Close : q') -> do
          put $ Tuple schema' q'
          pure $ Just query
        _ ->
          lift $ Left "parsing error: unbalanced parenthesis expression"

    Right (Keyword K.From : q) -> do
      lift $ Left "parsing error: FROM clause should be wrapped in parenthesis"

    Right _ ->
      pure Nothing

    Left err ->
      lift $ Left err

parseWhere :: Clause (Maybe Filter)
parseWhere = do
  Tuple schema tokens <- get
  case unwrap tokens of
    Right (Keyword K.Where : q) -> do
      put $ Tuple schema q
      condition <- parseCondition
      pure $ Just (Where condition)

    Right _ ->
      pure Nothing

    Left err ->
      lift $ Left err

parseCondition :: Clause Condition
parseCondition = do
  Tuple schema tokens <- get
  case unwrap tokens of
    Right (Word w : BooleanOp O.Eq : Word w' : q) -> do
      put $ Tuple schema q
      pure $ ConditionTerm (Eq (OpSelector (Field w)) (OpSelector (Field w')))

    Right _ ->
      lift $ Left "not implemented"

    Left err ->
      lift $ Left err

-- INSTANCES
instance showQuery :: Show Query where
  show (Select xs query filter _) =
    let
        query' = maybe "" (\q -> "\nFROM (" <> (show q) <> ")") query
        filter' = maybe "" (\f -> "\n" <> (show f)) filter
    in
        "SELECT " <> (intercalate ", " (map show xs))
        <> query'
        <> filter'

instance showSelector :: Show Selector where
  show (Field s) =
    s
  show (FieldAs s as) =
    s <> " AS " <> as
  show (Function f s s') =
    (show f) <> "(" <> s <> "." <> s' <> ")"

instance showFilter :: Show Filter where
  show (Where c) =
    "WHERE " <> (show c)

instance showCondition :: Show Condition where
  show (ConditionTerm c) =
    show c
  show (And c1 c2) =
    show c1 <> " AND " <> show c2
  show (Or c1 c2) =
    show c1 <> " OR " <> show c2

instance showOperator :: Show Operator where
  show (Eq a b) =
    show a <> " == " <> show b
  show (Neq a b) =
    show a <> " /= " <> show b
  show (Lt a b) =
    show a <> " < " <> show b
  show (Gt a b) =
    show a <> " > " <> show b

instance showOperand :: Show Operand where
  show (OpString s) =
    s
  show (OpNumber n) =
    show n
  show OpNull =
    "null"
  show (OpBoolean b) =
    show b
  show (OpSelector s) =
    show s

instance showFunc :: Show Func where
  show Avg =
    "AVG"
  show Count =
    "COUNT"
  show Max =
    "MAX"
  show Min =
    "MIN"
  show Sum =
    "SUM"


Remove unsafe stuff and things that belong elsewhere

module Global where

foreign import nan "var nan = NaN;" :: Number

foreign import isNaN :: Number -> Boolean

foreign import infinity "var infinity = Infinity;" :: Number

foreign import isFinite :: Number -> Boolean

foreign import parseInt
  "function parseInt(n) {\
  \  return function(radix) {\
  \    return parseInt(n, radix);\
  \  };\
  \}" :: String -> Number -> Number

foreign import parseFloat :: String -> Number

module Global where

foreign import nan "var nan = NaN;" :: Number

foreign import infinity "var infinity = Infinity;" :: Number

foreign import toExponential
  "function toExponential(n) {\
  \  return n.toExponential();\
  \}" :: Number -> String

foreign import toFixed
  "function toFixed(d) {\
  \  return function(n) {\
  \    return n.toFixed(d);\
  \  };\
  \}" :: Number -> Number -> String

foreign import toPrecision
  "function toPrecision(d) {\
  \  return function(n) {\
  \    return n.toPrecision(d);\
  \  };\
  \}" :: Number -> Number -> String

foreign import isFinite :: Number -> Boolean

foreign import parseFloat :: String -> Number

foreign import parseInt
  "function parseInt(n) {\
  \  return function(radix) {\
  \    return parseInt(n, radix);\
  \  };\
  \}" :: String -> Number -> Number

foreign import encodeURIComponent :: String -> String

foreign import decodeURIComponent :: String -> String

foreign import encodeURI :: String -> String

foreign import decodeURI :: String -> String

foreign import isNaN :: Number -> Boolean


Add list, application and term parser

Add list, application and term parser

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

num :: Parser String Atom
num = do
  sign <- option "" (string "-")
  eatSpaces
  str <- string "0" <|> nat
  return $ Num $ readInt 10 $ sign ++ str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  eatSpaces
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

list :: Parser String Expr -> Parser String Expr
list expr = do
  string "["
  eatSpaces
  ls <- expr `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return $ List ls

app :: Parser String Expr -> Parser String Expr
app expr = do
  str <- name
  exprs <- some (try $ eatSpaces *> expr)
  return $ App str exprs

bracket :: Parser String Expr -> Parser String Expr
bracket expr = do
  string "("
  eatSpaces
  e <- expr
  eatSpaces
  string ")"
  return e

base :: Parser String Expr -> Parser String Expr
base expr = list expr <|> bracket expr <|> (Atom <$> atom)

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (base expr)) <|> base expr

op :: forall a. Parser String a -> Op -> Parser String (Expr -> Expr -> Expr)
op opParser opType = try $
  (eatSpaces *> opParser *> eatSpaces) *> return (Binary opType)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (termApp expr) (mulP <|> divP)
  where
  mulP = op (string "*") Mul
  divP = op (string "`div`") Div

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term7l expr) (addP <|> subP)
  where
  addP = op (string "+" *> notFollowedBy (string "+")) Add
  subP = op (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = op (string ":") Cons
  appendP = op (string "++") Append

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (op (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (op (string "||") Or)

expr :: Parser String Expr
expr = fix1 $ \expr -> term2r expr

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

num :: Parser String Atom
num = do
  sign <- option "" (string "-")
  eatSpaces
  str <- string "0" <|> nat
  return $ Num $ readInt 10 $ sign ++ str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  eatSpaces
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"