reverte path change

reverte path change

module Web
  ( exprToJQuery
  , getPath
  , idExpr
  ) where

import Prelude (class Monad, Unit, return, flip, bind, (<<<), (<$>), (++), (&&), (>), (>>=), void, ($), unit, show, id, (-),(+),map,(==), class Show)
import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List (List(Nil, Cons), singleton, fromList, toList, length, (..), zipWithA,concat,zip)
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign, Foreign())
import Data.Maybe (Maybe(..))
import Data.Tuple

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import Control.Monad.State
import DOM (DOM)

import AST (Atom(..), Binding(..), Expr(..), Op(), pPrintOp,Output(..),Type,IndexTree(..),IBinding(..),TypeTree(..),TypeBinding(..))
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType,mapM)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2
    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case toStr es of
                  Just str  -> string str t i
                  Nothing -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                                list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t >>= addIdtoDiv i
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i
    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs t i
    {} -> makeDiv "You found a Bug" Nil

atom :: forall eff. Atom -> Type -> Int ->  Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t  i   = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool true) t i = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool false) t i= makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Char c) t  i  = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Name name) t i = do
 jtypExp <- makeDiv "" (singleton "atom name typExpContainer")
 jExpand <- buildExpandDiv t
 J.append jExpand jtypExp
 jName <- makeDiv name (toList ["atom", "name", "expr"]) >>= addTypetoDiv t >>= addIdtoDiv i
 J.append jName jtypExp
 return jtypExp

binding :: forall eff. Tuple IBinding (Tuple Binding  TypeBinding) -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (ILit i) (Tuple (Lit a) (TLit t))       -> atom a t i
  Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple i1 (Tuple b tb))            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple i2 (Tuple bs tbs))           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (IListLit is i)(Tuple (ListLit bs) (TListLit tbs t)) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip is (zip bs tbs)
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (INTupleLit is i)(Tuple (NTupleLit bs) (TNTupleLit tbs t))-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip is (zip bs tbs))
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t i = do
  jtypExp <- makeDiv "" (singleton "lambda typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jLam <- makeDiv "" (singleton "lambda expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  J.append jLam jtypExp
  return jtypExp

binary :: forall eff. Op -> Type -> Int -> Type -> Int -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt opi t i j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t >>= addIdtoDiv i
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t i = do
  jtypExp <- makeDiv "" (singleton "section typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jSect <- makeDiv "" (singleton "section expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  J.append jSect jtypExp
  return jtypExp

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  jtypExp <- makeDiv "" (singleton "if typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dIf <- makeDiv "" (singleton "if expr") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  J.append dIf jtypExp
  return jtypExp

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
tuple js t i = do
  jtypExp <- makeDiv "" (singleton "tuple typExpContainer")
  dtuple <- makeDiv "" (singleton "tuple expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
list js t   i  = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dls <- makeDiv "" (singleton "list expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "[" (singleton "brace")
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  J.append dls jtypExp
  return jtypExp

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. String -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string str t i = makeDiv ("\"" ++ str ++ "\"") (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i

toStr :: List Expr -> Maybe String
toStr Nil = Nothing
toStr ls  = (joinWith "" <<< fromList) <$> for ls extract
  where
   extract:: Expr -> Maybe String
   extract (Atom (Char s)) = Just s
   extract _               = Nothing

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs t i = do
  jtypExp <- makeDiv "" (singleton "app typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dApp <- makeDiv "" (singleton "app expr") >>= addTypetoDiv t >>= addIdtoDiv i
  J.addClass "func" jFunc
  J.addClass "funcContainer" jFunc
  innerExpr <- J.find ".expr" jFunc
  J.addClass "func" innerExpr
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  J.append dApp jtypExp
  return jtypExp

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)
  return d

emptyJQuery:: forall eff . Eff (dom :: DOM | eff) J.JQuery
emptyJQuery = J.create ""

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  text <- J.getText d
  J.clear d
  outer <- makeDiv "" $ Cons "tooltip-outer" Nil
  inner <- makeDiv (prettyPrintType typ) $ Cons "tooltip-inner" Nil
  J.append inner outer
  J.append outer d
  J.appendText text d
  -- J.on "mouseover" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.css {visibility: "visible"} outer) d
  -- J.on "mouseout" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.css {visibility: "hidden"} outer) d

addIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addIdtoDiv id d = do
    J.setAttr "id" ("expr"++(show id)) d

addTypIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypIdtoDiv id d = do
    J.setAttr "id" ("typ"++(show id)) d

addResultIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addResultIdtoDiv id d = do
    J.setAttr "id" ("typ" ++ (show id) ++ "result") d

buildExpandDiv:: forall eff. Type  -> Eff (dom :: DOM | eff) J.JQuery
buildExpandDiv t  = do
  typC <- makeDiv (prettyPrintType t) $ Cons "type" Nil
  expandC <- makeDiv "▾" $ Cons "expand"  Nil
  J.append typC expandC
  J.on "click" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.setVisible true typC) expandC
  J.on "click" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.setVisible false typC) typC
  J.css {display: "inline-block"} typC
  return expandC

idExpr:: Expr -> IndexTree
idExpr e = fst $ runState (indexExpr e) {count:0}

indexExpr:: Expr -> State {count:: Int} IndexTree
indexExpr (Atom _) = do
                  i <- fresh
                  return $ IAtom i
indexExpr (List es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ IListTree is i
indexExpr (NTuple es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ INTuple is i
indexExpr (Binary _ e1 e2) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  i' <- fresh
                  return $ (IBinary i' i1 i2 i)
indexExpr (Unary _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ IUnary i'' i i'
indexExpr (SectL e _) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectL i i'' i'
indexExpr (SectR _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectR i'' i i'
indexExpr (PrefixOp _) = do
                  i <- fresh
                  return $ IPrefixOp i
indexExpr (IfExpr e1 e2 e3) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i3 <- indexExpr e3
                  i <- fresh
                  return $ IIfExpr i1 i2 i3 i
indexExpr (LetExpr b e1 e2) = do
                  ib <- indexBinding b
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  return $ ILetExpr ib i1 i2 i
indexExpr (Lambda bs e) = do
                 ibs <- mapM indexBinding bs
                 i <- indexExpr e
                 i' <- fresh
                 return $ ILambda ibs i i'
indexExpr (App e es) = do
                e1 <- indexExpr e
                is <- mapM indexExpr es
                i <- fresh
                return $ IApp e1 is i

indexBinding:: Binding -> State {count :: Int} IBinding
indexBinding (Lit _) = do
                    i <- fresh
                    return $ ILit i
indexBinding (ConsLit b1 b2 ) = do
                      i1 <- indexBinding b1
                      i2 <- indexBinding b2
                      i <- fresh
                      return $ IConsLit i1 i2 i
indexBinding (ListLit bs) = do
                        is <- mapM indexBinding bs
                        i <- fresh
                        return $ IListLit is i
indexBinding (NTupleLit bs) = do
                      is <- mapM indexBinding bs
                      i <- fresh
                      return $ INTupleLit is i

fresh ::State {count:: Int} Int
fresh = do
  {count = count} <- get
  put {count:count+1}
  return count

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

module Web
  ( exprToJQuery
  , getPath
  , idExpr
  ) where

import Prelude (class Monad, Unit, return, flip, bind, (<<<), (<$>), (++), (&&), (>), (>>=), void, ($), unit, show, id, (-),(+),map,(==), class Show)
import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List (List(Nil, Cons), singleton, fromList, toList, length, (..), zipWithA,concat,zip)
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign, Foreign())
import Data.Maybe (Maybe(..))
import Data.Tuple

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import Control.Monad.State
import DOM (DOM)

import AST (Atom(..), Binding(..), Expr(..), Op(), pPrintOp,Output(..),Type,IndexTree(..),IBinding(..),TypeTree(..),TypeBinding(..))
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType,mapM)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2
    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case toStr es of
                  Just str  -> string str t i
                  Nothing -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                                list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t >>= addIdtoDiv i
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i
    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go ((p <<< Fst) <<< Snd) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs t i
    {} -> makeDiv "You found a Bug" Nil

atom :: forall eff. Atom -> Type -> Int ->  Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t  i   = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool true) t i = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool false) t i= makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Char c) t  i  = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Name name) t i = do
 jtypExp <- makeDiv "" (singleton "atom name typExpContainer")
 jExpand <- buildExpandDiv t
 J.append jExpand jtypExp
 jName <- makeDiv name (toList ["atom", "name", "expr"]) >>= addTypetoDiv t >>= addIdtoDiv i
 J.append jName jtypExp
 return jtypExp

binding :: forall eff. Tuple IBinding (Tuple Binding  TypeBinding) -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (ILit i) (Tuple (Lit a) (TLit t))       -> atom a t i
  Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple i1 (Tuple b tb))            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple i2 (Tuple bs tbs))           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (IListLit is i)(Tuple (ListLit bs) (TListLit tbs t)) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip is (zip bs tbs)
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (INTupleLit is i)(Tuple (NTupleLit bs) (TNTupleLit tbs t))-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip is (zip bs tbs))
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t i = do
  jtypExp <- makeDiv "" (singleton "lambda typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jLam <- makeDiv "" (singleton "lambda expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  J.append jLam jtypExp
  return jtypExp

binary :: forall eff. Op -> Type -> Int -> Type -> Int -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt opi t i j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t >>= addIdtoDiv i
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t i = do
  jtypExp <- makeDiv "" (singleton "section typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jSect <- makeDiv "" (singleton "section expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  J.append jSect jtypExp
  return jtypExp

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  jtypExp <- makeDiv "" (singleton "if typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dIf <- makeDiv "" (singleton "if expr") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  J.append dIf jtypExp
  return jtypExp

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
tuple js t i = do
  jtypExp <- makeDiv "" (singleton "tuple typExpContainer")
  dtuple <- makeDiv "" (singleton "tuple expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
list js t   i  = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dls <- makeDiv "" (singleton "list expr") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "[" (singleton "brace")
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  J.append dls jtypExp
  return jtypExp

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. String -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string str t i = makeDiv ("\"" ++ str ++ "\"") (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i

toStr :: List Expr -> Maybe String
toStr Nil = Nothing
toStr ls  = (joinWith "" <<< fromList) <$> for ls extract
  where
   extract:: Expr -> Maybe String
   extract (Atom (Char s)) = Just s
   extract _               = Nothing

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs t i = do
  jtypExp <- makeDiv "" (singleton "app typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dApp <- makeDiv "" (singleton "app expr") >>= addTypetoDiv t >>= addIdtoDiv i
  J.addClass "func" jFunc
  J.addClass "funcContainer" jFunc
  innerExpr <- J.find ".expr" jFunc
  J.addClass "func" innerExpr
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  J.append dApp jtypExp
  return jtypExp

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)
  return d

emptyJQuery:: forall eff . Eff (dom :: DOM | eff) J.JQuery
emptyJQuery = J.create ""

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  text <- J.getText d
  J.clear d
  outer <- makeDiv "" $ Cons "tooltip-outer" Nil
  inner <- makeDiv (prettyPrintType typ) $ Cons "tooltip-inner" Nil
  J.append inner outer
  J.append outer d
  J.appendText text d
  -- J.on "mouseover" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.css {visibility: "visible"} outer) d
  -- J.on "mouseout" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.css {visibility: "hidden"} outer) d

addIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addIdtoDiv id d = do
    J.setAttr "id" ("expr"++(show id)) d

addTypIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypIdtoDiv id d = do
    J.setAttr "id" ("typ"++(show id)) d

addResultIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addResultIdtoDiv id d = do
    J.setAttr "id" ("typ" ++ (show id) ++ "result") d

buildExpandDiv:: forall eff. Type  -> Eff (dom :: DOM | eff) J.JQuery
buildExpandDiv t  = do
  typC <- makeDiv (prettyPrintType t) $ Cons "type" Nil
  expandC <- makeDiv "▾" $ Cons "expand"  Nil
  J.append typC expandC
  J.on "click" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.setVisible true typC) expandC
  J.on "click" (\e _ -> J.stopImmediatePropagation e >>= \_ -> J.setVisible false typC) typC
  J.css {display: "inline-block"} typC
  return expandC

idExpr:: Expr -> IndexTree
idExpr e = fst $ runState (indexExpr e) {count:0}

indexExpr:: Expr -> State {count:: Int} IndexTree
indexExpr (Atom _) = do
                  i <- fresh
                  return $ IAtom i
indexExpr (List es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ IListTree is i
indexExpr (NTuple es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ INTuple is i
indexExpr (Binary _ e1 e2) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  i' <- fresh
                  return $ (IBinary i' i1 i2 i)
indexExpr (Unary _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ IUnary i'' i i'
indexExpr (SectL e _) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectL i i'' i'
indexExpr (SectR _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectR i'' i i'
indexExpr (PrefixOp _) = do
                  i <- fresh
                  return $ IPrefixOp i
indexExpr (IfExpr e1 e2 e3) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i3 <- indexExpr e3
                  i <- fresh
                  return $ IIfExpr i1 i2 i3 i
indexExpr (LetExpr b e1 e2) = do
                  ib <- indexBinding b
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  return $ ILetExpr ib i1 i2 i
indexExpr (Lambda bs e) = do
                 ibs <- mapM indexBinding bs
                 i <- indexExpr e
                 i' <- fresh
                 return $ ILambda ibs i i'
indexExpr (App e es) = do
                e1 <- indexExpr e
                is <- mapM indexExpr es
                i <- fresh
                return $ IApp e1 is i

indexBinding:: Binding -> State {count :: Int} IBinding
indexBinding (Lit _) = do
                    i <- fresh
                    return $ ILit i
indexBinding (ConsLit b1 b2 ) = do
                      i1 <- indexBinding b1
                      i2 <- indexBinding b2
                      i <- fresh
                      return $ IConsLit i1 i2 i
indexBinding (ListLit bs) = do
                        is <- mapM indexBinding bs
                        i <- fresh
                        return $ IListLit is i
indexBinding (NTupleLit bs) = do
                      is <- mapM indexBinding bs
                      i <- fresh
                      return $ INTupleLit is i

fresh ::State {count:: Int} Int
fresh = do
  {count = count} <- get
  put {count:count+1}
  return count

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


functor impl for EArray

functor impl for EArray

module KanColle.Expedition.New.EArray
  ( EArray()
  , mkEA
  , indEA
  ) where

import Prelude
import Partial.Unsafe
import Partial
import Data.Array as A
import Data.Array.Partial as AP

-- array wrappered for all 40 expeditions
newtype EArray a = EA (Array a)

mkEA :: forall a. Array a -> EArray a
mkEA xs
    | A.length xs == 40 = EA xs
    | otherwise = unsafePartial (crash "expecting exactly 40 elements")

indEA :: forall a. EArray a -> Int -> a
indEA (EA xs) i
    | 1 <= i && i <= 40 = unsafePartial (AP.unsafeIndex xs (i-1))
    | otherwise = unsafePartial (crash "index out of range")

instance functorEArray :: Functor EArray where
  map f (EA xs) = EA (map f xs)


Made the code more succinct.

Made the code more succinct.

module Lemmingpants where

import Prelude

import Components.Admin as CA
import Components.Admin.ListAttendees as CAL
import Components.Home as CH
import Components.Login as CL
import Components.Overhead as CO
import Components.Registration as CR
import Control.Alt ((<|>))
import Control.Monad.Except (except, runExcept)
import Data.Array as A
import Data.Either (Either(..), note)
import Data.Either.Nested (Either6)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (Coproduct6)
import Data.Lens (over, set, traverseOf)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.String (toLower)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(..), fail, readString, renderForeignError, unsafeFromForeign)
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Routing.Match (Match, lit)
import Simple.JSON (readImpl, readJSON')
import Type.Prelude (SProxy(..))
import Types.Agenda as AG
import Types.Attendee as AT
import Types.Flash as FL
import Types.Lens (_withId)
import Types.Speaker as S
import Types.SpeakerQueue as SQ
import Types.Token (Payload(..), Token(..))
import Types.Token as TT
import Web.HTML (Window)

type ChildQuery = Coproduct6 CR.Query CO.Query CA.Query CAL.Query CL.Query CH.Query
type ChildSlot  = Either6 Int Int Int Int Int Int

data WSAction
  = Insert
  | Update

data Location
  = Home
  | Registration
  | Overhead
  | Admin
  | AdminListAttendees
  | Login

instance shLoc :: Show Location where
  show
    = case _ of
        Home               -> "Home"
        Registration       -> "Registration"
        Overhead           -> "Overhead"
        Admin              -> "Admin"
        AdminListAttendees -> "Admin: List attendees"
        Login              -> "Login"

locations :: Match Location
locations
  =   (Registration       <$ lit "registration")
  <|> (Overhead           <$ lit "overhead")
  <|> (Admin              <$ lit "admin")
  <|> (Admin              <$ lit "admin")
  <|> (AdminListAttendees <$ lit "adminAttendees")
  <|> (Login              <$ lit "login")
  <|> (Home               <$ lit "")

type State =
  { currentLocation :: Location
  , token           :: TT.Token
  , flash           :: Maybe FL.Flash
  , agenda          :: AG.Agenda
  , attendees       :: AT.AttendeeDB
  , showRegForm     :: Boolean
  , window          :: Window
  }

data Query a
  = ChangePage      Location   a
  | SignOut                    a
  | AdminMsg        CA.Message a
  | LoginMsg        CL.Message a
  | RegistrationMsg CR.Message a
  | WSMsg           Foreign    a

type Input = { token :: TT.Token, agenda :: AG.Agenda, attendees :: AT.AttendeeDB, window :: Window }

component :: H.Component HH.HTML Query Input Void Aff
component =
  H.parentComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where
    initialState :: Input -> State
    initialState i =
      { currentLocation: Home
      , token:           i.token
      , flash:           Nothing
      , agenda:          i.agenda
      , attendees:       i.attendees
      , showRegForm:     true
      , window:          i.window
      }

    render :: State -> H.ParentHTML Query ChildQuery ChildSlot Aff
    render state =
      HH.div
        [ HP.id_ (toLower (show state.currentLocation)) ]
        [ HH.nav_
          [ HH.menu_ (
            [ HH.li_ [HH.a [HP.href "#"]             [HH.text "Home"]]
            , HH.li_ [HH.a [HP.href "#registration"] [HH.text "Registration"]]
            , HH.li_ [HH.a [HP.href "#overhead"]     [HH.text "Overhead"]]
            ] <> (if pl.role == "admin_user"
                   then [ HH.li_
                      [ HH.a [HP.href "#admin"] [HH.text "Admin"]
                      , HH.menu
                        [ HP.id_ "submenu" ]
                        [ HH.li_ [ HH.a [HP.href "#adminAttendees"] [HH.text "List attendees"] ] ]
                      ]
                    ]
                    else mempty)
            <> [ loginlogoutlink state ])
          ]
        , HH.div
          [HP.class_ (HH.ClassName "container")]
          (maybe [] (\(FL.Flash f) -> [ HH.div [ HP.id_ "flash", (HP.class_ (HH.ClassName (show f.typ))) ] [ HH.text f.msg ] ]) state.flash
            <> [locationToSlot state.currentLocation state])
        ]
      where
        (Payload pl) = let (Token t) = state.token in t.payload

        loginlogoutlink
          :: State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        loginlogoutlink s =
          let (TT.Token {payload}) = s.token
              (TT.Payload p)       = payload
           in if p.role == "admin_user"
                -- Blergh... hack... blergh...
                -- TODO: Unhack this!
                then HH.li_ [HH.a [HP.href "#signout", HE.onClick (HE.input_ SignOut)] [HH.text "Sign out"]]
                else HH.li_ [HH.a [HP.href "#login"]   [HH.text "Login"]]

        locationToSlot
          :: Location
          -> State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        locationToSlot l s =
          case l of
            Registration       -> go CP.cp1 1 CR.component  rs   (HE.input RegistrationMsg)
            Overhead           -> go CP.cp2 2 CO.component  ohs  (const Nothing)
            Admin              -> go CP.cp3 3 CA.component  s'   (HE.input AdminMsg)
            AdminListAttendees -> go CP.cp4 4 CAL.component alas (const Nothing)
            Login              -> go CP.cp5 5 CL.component  ls   (HE.input LoginMsg)
            Home               -> go CP.cp6 6 CH.component  unit (const Nothing)
          where
            go :: forall g i o
               . CP.ChildPath g ChildQuery Int ChildSlot
              -> Int
              -> H.Component HH.HTML g i o Aff
              -> i
              -> (o -> Maybe (Query Unit))
              -> H.ParentHTML Query ChildQuery ChildSlot Aff
            go cp p c i f = HH.slot' cp p c i f

            ls   = { token: s.token }
            rs   = { token: s.token, showForm: s.showRegForm }
            s'   = { token: s.token, agenda: s.agenda, attendees: s.attendees }
            ohs  = { agenda: s.agenda, attendees: s.attendees }
            alas = { attendees: s.attendees }

    eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void Aff
    eval =
      case _ of
        ChangePage l next ->
          H.modify (_ {currentLocation = l, flash = Nothing, showRegForm = true}) *> pure next
        SignOut      next -> do
          s <- H.get
          H.liftAff (TT.removeToken s.window)
          pure next
        AdminMsg   m next ->
          case m of
            CA.Flash s -> flash s next
        LoginMsg   m next ->
          case m of
            CL.NewToken t -> do
              s <- H.modify (_ {token = t})
              H.liftAff (TT.saveToken s.window t)
              pure next
            CL.Flash s -> flash s next
        RegistrationMsg m next ->
          case m of
            CR.FrmVsbl b -> H.modify (\s -> s { showRegForm = b }) *> pure next
            CR.Flash   s -> flash s next
        WSMsg fr next -> do
          -- Log the message to the console.
          liftEffect $ log $ unsafeFromForeign fr
          state <- H.get
          -- In case you think this is inefficient and want to change
          -- `readJSON' =<< readString` into `read'`, do know that
          -- there is a bug that makes the parsing fail if you only
          -- run read' on your foreign data. I don't know why, but I
          -- intend to find out.
          --
          -- Regards, A.
          case runExcept (dispatcher state =<< readJSON' =<< readString fr) of
            Left  es -> flash (FL.mkFlash (foldMap renderForeignError es) FL.Error) next
            Right s' -> H.put s' *> pure next
      where
        flash s next =
          H.modify (_ {flash = Just s})
          *> pure next

        dispatcher
          :: State
          -> { channel :: String, event :: String, payload :: Foreign }
          -> F State
        dispatcher state r =
          case r.event of
            "agenda_item_insert"   -> handleAgendaItem   (readImpl r.payload) Insert state
            "agenda_item_update"   -> handleAgendaItem   (readImpl r.payload) Update state
            "attendee_insert"      -> handleAttendee     (readImpl r.payload)        state
            "attendee_update"      -> handleAttendee     (readImpl r.payload)        state
            "speaker_insert"       -> handleSpeaker      (readImpl r.payload) Insert state
            "speaker_update"       -> handleSpeaker      (readImpl r.payload) Update state
            "speaker_queue_insert" -> handleSpeakerQueue (readImpl r.payload) Insert state
            "speaker_queue_update" -> handleSpeakerQueue (readImpl r.payload) Update state
            _                      -> fail (ForeignError "Anything can happen.")

        -- TODO: Make _ALL_ the go functions scream and shout if they can't update stuff.
        handleAgendaItem
          :: F { id         :: Int
               , supertitle :: Maybe String
               , title      :: String
               , order_     :: Int
               , state      :: String
               }
             -> WSAction
             -> State
             -> F State
        handleAgendaItem fr action st =
          fr
            >>= \air -> go action air st.agenda
            <#> \r   -> st { agenda = AG.jumpToFirstActive r }
          where
            go Insert air ag = pure (AG.insert (newAI air) ag)
            go Update air ag =
              except (note (pure (ForeignError "ERROR: handleAgendaItem: Could not update AgendaItem!"))
                (traverseOf (AG._AgendaItems <<< _withId air.id) (\(AG.AgendaItem {speakerQueues}) ->
                  Just $ set (_Newtype <<< prop (SProxy :: SProxy "speakerQueues")) speakerQueues (newAI air))
                  ag))

            newAI { id, supertitle, title, order_, state } =
              AG.AgendaItem { id, supertitle, title, order_, state, speakerQueues: mempty }

        handleAttendee :: F AT.Attendee -> State -> F State
        handleAttendee fr state =
            fr <#> \at -> state { attendees = AT.insertAttendee at state.attendees }

        handleSpeaker
          :: F { id               :: Int
               , speaker_queue_id :: Int
               , attendee_id      :: Int
               , state            :: S.SpeakerState
               , times_spoken     :: Maybe Int
               , agenda_item_id   :: Int
               }
             -> WSAction
             -> State
             -> F State
        handleSpeaker fr action st =
          fr >>= \r ->
            except (note
              (pure (ForeignError ("Modifying the speaker failed.")))
              (traverseOf
                (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId r.agenda_item_id <<< AG._SpeakerQueues <<< _withId r.speaker_queue_id)
                (Just <<< go action r)
                st))
          where
            go Insert r = over SQ._Speakers $ A.insert $ newSpeaker r
            go Update r = set (SQ._Speakers <<< _withId r.id) (newSpeaker r)

            newSpeaker {id, attendee_id, state, times_spoken} =
              S.Speaker { id, attendeeId: attendee_id, state, timesSpoken: fromMaybe 0 times_spoken }

        handleSpeakerQueue
          :: F { id             :: Int
               , agenda_item_id :: Int
               , state          :: String
               }
          -> WSAction
          -> State
          -> F State
        handleSpeakerQueue r action s =
          r >>= \{id, agenda_item_id, state} ->
          except (note
            (pure (ForeignError "Modifying the speaker queue failed."))
            (traverseOf (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId agenda_item_id) (go action {id, state}) s))
          where
            go Insert {id, state} ai = Just $ AG.pushSQ (SQ.SpeakerQueue {id, state, speakers: mempty}) ai
            go Update {id, state} ai =
              if state == "done"
                then AG.popSQIfMatchingId id ai
                else Nothing

module Lemmingpants where

import Prelude

import Components.Admin as CA
import Components.Admin.ListAttendees as CAL
import Components.Home as CH
import Components.Login as CL
import Components.Overhead as CO
import Components.Registration as CR
import Control.Alt ((<|>))
import Control.Monad.Except (except, runExcept)
import Data.Array as A
import Data.Either (Either(..), note)
import Data.Either.Nested (Either6)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (Coproduct6)
import Data.Lens (over, set, traverseOf)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.String (toLower)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(..), fail, readString, renderForeignError, unsafeFromForeign)
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Routing.Match (Match, lit)
import Simple.JSON (readImpl, readJSON')
import Type.Prelude (SProxy(..))
import Types.Agenda as AG
import Types.Attendee as AT
import Types.Flash as FL
import Types.Lens (_withId)
import Types.Speaker as S
import Types.SpeakerQueue as SQ
import Types.Token (Payload(..), Token(..))
import Types.Token as TT
import Web.HTML (Window)

type ChildQuery = Coproduct6 CR.Query CO.Query CA.Query CAL.Query CL.Query CH.Query
type ChildSlot  = Either6 Int Int Int Int Int Int

data WSAction
  = Insert
  | Update

data Location
  = Home
  | Registration
  | Overhead
  | Admin
  | AdminListAttendees
  | Login

instance shLoc :: Show Location where
  show
    = case _ of
        Home               -> "Home"
        Registration       -> "Registration"
        Overhead           -> "Overhead"
        Admin              -> "Admin"
        AdminListAttendees -> "Admin: List attendees"
        Login              -> "Login"

locations :: Match Location
locations
  =   (Registration       <$ lit "registration")
  <|> (Overhead           <$ lit "overhead")
  <|> (Admin              <$ lit "admin")
  <|> (Admin              <$ lit "admin")
  <|> (AdminListAttendees <$ lit "adminAttendees")
  <|> (Login              <$ lit "login")
  <|> (Home               <$ lit "")

type State =
  { currentLocation :: Location
  , token           :: TT.Token
  , flash           :: Maybe FL.Flash
  , agenda          :: AG.Agenda
  , attendees       :: AT.AttendeeDB
  , showRegForm     :: Boolean
  , window          :: Window
  }

data Query a
  = ChangePage      Location   a
  | SignOut                    a
  | AdminMsg        CA.Message a
  | LoginMsg        CL.Message a
  | RegistrationMsg CR.Message a
  | WSMsg           Foreign    a

type Input = { token :: TT.Token, agenda :: AG.Agenda, attendees :: AT.AttendeeDB, window :: Window }

component :: H.Component HH.HTML Query Input Void Aff
component =
  H.parentComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where
    initialState :: Input -> State
    initialState i =
      { currentLocation: Home
      , token:           i.token
      , flash:           Nothing
      , agenda:          i.agenda
      , attendees:       i.attendees
      , showRegForm:     true
      , window:          i.window
      }

    render :: State -> H.ParentHTML Query ChildQuery ChildSlot Aff
    render state =
      HH.div
        [ HP.id_ (toLower (show state.currentLocation)) ]
        [ HH.nav_
          [ HH.menu_ (
            [ HH.li_ [HH.a [HP.href "#"]             [HH.text "Home"]]
            , HH.li_ [HH.a [HP.href "#registration"] [HH.text "Registration"]]
            , HH.li_ [HH.a [HP.href "#overhead"]     [HH.text "Overhead"]]
            ] <> (if pl.role == "admin_user"
                   then [ HH.li_
                      [ HH.a [HP.href "#admin"] [HH.text "Admin"]
                      , HH.menu
                        [ HP.id_ "submenu" ]
                        [ HH.li_ [ HH.a [HP.href "#adminAttendees"] [HH.text "List attendees"] ] ]
                      ]
                    ]
                    else mempty)
            <> [ loginlogoutlink state ])
          ]
        , HH.div
          [HP.class_ (HH.ClassName "container")]
          (maybe [] (\(FL.Flash f) -> [ HH.div [ HP.id_ "flash", (HP.class_ (HH.ClassName (show f.typ))) ] [ HH.text f.msg ] ]) state.flash
            <> [locationToSlot state.currentLocation state])
        ]
      where
        (Payload pl) = let (Token t) = state.token in t.payload

        loginlogoutlink
          :: State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        loginlogoutlink s =
          let (TT.Token {payload}) = s.token
              (TT.Payload p)       = payload
           in if p.role == "admin_user"
                -- Blergh... hack... blergh...
                -- TODO: Unhack this!
                then HH.li_ [HH.a [HP.href "#signout", HE.onClick (HE.input_ SignOut)] [HH.text "Sign out"]]
                else HH.li_ [HH.a [HP.href "#login"]   [HH.text "Login"]]

        locationToSlot
          :: Location
          -> State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        locationToSlot l s =
          case l of
            Registration       -> go CP.cp1 1 CR.component  rs   (HE.input RegistrationMsg)
            Overhead           -> go CP.cp2 2 CO.component  ohs  (const Nothing)
            Admin              -> go CP.cp3 3 CA.component  s'   (HE.input AdminMsg)
            AdminListAttendees -> go CP.cp4 4 CAL.component alas (const Nothing)
            Login              -> go CP.cp5 5 CL.component  ls   (HE.input LoginMsg)
            Home               -> go CP.cp6 6 CH.component  unit (const Nothing)
          where
            go :: forall g i o
               . CP.ChildPath g ChildQuery Int ChildSlot
              -> Int
              -> H.Component HH.HTML g i o Aff
              -> i
              -> (o -> Maybe (Query Unit))
              -> H.ParentHTML Query ChildQuery ChildSlot Aff
            go cp p c i f = HH.slot' cp p c i f

            ls   = { token: s.token }
            rs   = { token: s.token, showForm: s.showRegForm }
            s'   = { token: s.token, agenda: s.agenda, attendees: s.attendees }
            ohs  = { agenda: s.agenda, attendees: s.attendees }
            alas = { attendees: s.attendees }

    eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void Aff
    eval =
      case _ of
        ChangePage l next ->
          H.modify (_ {currentLocation = l, flash = Nothing, showRegForm = true}) *> pure next
        SignOut      next -> do
          s <- H.get
          H.liftAff (TT.removeToken s.window)
          pure next
        AdminMsg   m next ->
          case m of
            CA.Flash s -> flash s next
        LoginMsg   m next ->
          case m of
            CL.NewToken t -> do
              s <- H.modify (_ {token = t})
              H.liftAff (TT.saveToken s.window t)
              pure next
            CL.Flash s -> flash s next
        RegistrationMsg m next ->
          case m of
            CR.FrmVsbl b -> H.modify (\s -> s { showRegForm = b }) *> pure next
            CR.Flash   s -> flash s next
        WSMsg fr next -> do
          -- Log the message to the console.
          liftEffect $ log $ unsafeFromForeign fr
          state <- H.get
          -- In case you think this is inefficient and want to change
          -- `readJSON' =<< readString` into `read'`, do know that
          -- there is a bug that makes the parsing fail if you only
          -- run read' on your foreign data. I don't know why, but I
          -- intend to find out.
          --
          -- Regards, A.
          case runExcept (dispatcher state =<< readJSON' =<< readString fr) of
            Left  es -> flash (FL.mkFlash (foldMap renderForeignError es) FL.Error) next
            Right s' -> H.put s' *> pure next
      where
        flash s next =
          H.modify (_ {flash = Just s})
          *> pure next

        dispatcher
          :: State
          -> { channel :: String, event :: String, payload :: Foreign }
          -> F State
        dispatcher state r =
          case r.event of
            "agenda_item_insert"   -> handleAgendaItem   (readImpl r.payload) Insert state
            "agenda_item_update"   -> handleAgendaItem   (readImpl r.payload) Update state
            "attendee_insert"      -> handleAttendee     (readImpl r.payload)        state
            "attendee_update"      -> handleAttendee     (readImpl r.payload)        state
            "speaker_insert"       -> handleSpeaker      (readImpl r.payload) Insert state
            "speaker_update"       -> handleSpeaker      (readImpl r.payload) Update state
            "speaker_queue_insert" -> handleSpeakerQueue (readImpl r.payload) Insert state
            "speaker_queue_update" -> handleSpeakerQueue (readImpl r.payload) Update state
            _                      -> fail (ForeignError "Anything can happen.")

        -- TODO: Make _ALL_ the go functions scream and shout if they can't update stuff.
        handleAgendaItem
          :: F { id         :: Int
               , supertitle :: Maybe String
               , title      :: String
               , order_     :: Int
               , state      :: String
               }
             -> WSAction
             -> State
             -> F State
        handleAgendaItem fr action st =
          fr
            >>= \air -> go action air st.agenda
            <#> \r   -> st { agenda = AG.jumpToFirstActive r }
          where
            go Insert air ag = pure (AG.insert (newAI air) ag)
            go Update air ag =
              except (note (pure (ForeignError "ERROR: handleAgendaItem: Could not update AgendaItem!"))
                (traverseOf (AG._AgendaItems <<< _withId air.id) (\(AG.AgendaItem {speakerQueues}) ->
                  Just $ set (_Newtype <<< prop (SProxy :: SProxy "speakerQueues")) speakerQueues (newAI air))
                  ag))

            newAI { id, supertitle, title, order_, state } =
              AG.AgendaItem { id, supertitle, title, order_, state, speakerQueues: mempty }

        handleAttendee :: F AT.Attendee -> State -> F State
        handleAttendee fr state =
            fr <#> \at -> state { attendees = AT.insertAttendee at state.attendees }

        handleSpeaker
          :: F { id               :: Int
               , speaker_queue_id :: Int
               , attendee_id      :: Int
               , state            :: S.SpeakerState
               , times_spoken     :: Maybe Int
               , agenda_item_id   :: Int
               }
             -> WSAction
             -> State
             -> F State
        handleSpeaker fr action st =
          fr >>= \r ->
            except (note
              (pure (ForeignError ("Modifying the speaker failed.")))
              (traverseOf
                (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId r.agenda_item_id <<< AG._SpeakerQueues <<< _withId r.speaker_queue_id)
                (Just <<< go action r)
                st))
          where
            go Insert r = over SQ._Speakers $ A.insert $ newSpeaker r
            go Update r = set (SQ._Speakers <<< _withId r.id) (newSpeaker r)

            newSpeaker {id, attendee_id, state, times_spoken} =
              let ts = fromMaybe 0 times_spoken
               in S.Speaker { id, attendeeId: attendee_id, state, timesSpoken: ts }

        handleSpeakerQueue
          :: F { id             :: Int
               , agenda_item_id :: Int
               , state          :: String
               }
          -> WSAction
          -> State
          -> F State
        handleSpeakerQueue r action s =
          r >>= \{id, agenda_item_id, state} ->
          except (note
            (pure (ForeignError "Modifying the speaker queue failed."))
            (traverseOf (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId agenda_item_id) (go action {id, state}) s))
          where
            go Insert {id, state} ai = Just $ AG.pushSQ (SQ.SpeakerQueue {id, state, speakers: mempty}) ai
            go Update {id, state} ai =
              if state == "done"
                then AG.popSQIfMatchingId id ai
                else Nothing