Remove class form empty divs => not visible

module Web
  ( exprToJQuery
  , getPath
  , typetoJQuery
  , idExpr
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.State
import Control.Monad.Eff.Class

import AST
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 isString es of
                  true  -> string es t i
                  false -> 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
    {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 = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t >>= addIdtoDiv i

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
  jLam <- makeDiv "" (singleton "lambda") >>= 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
  return jLam

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 i
  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
  jSect <- makeDiv "" (singleton "section") >>= 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
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  dIf <- makeDiv "" (singleton "if") >>= 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
  return dIf

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
  dtuple <- makeDiv "" (singleton "tuple") >>= 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
  dls <- makeDiv "" (singleton "list") >>= 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
  return dls

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

string :: forall eff. List Expr -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string es t i = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i
  return dstring

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

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
  J.setAttr "title" (prettyPrintType typ) 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

dummyExpr:: Expr
dummyExpr =  Atom $ AInt 0

typetoJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
typetoJQuery {typ:TListTree ls t, idTree: IListTree is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TNTuple ls t, idTree: INTuple is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
    container <- makeDiv "" Nil
    typContainer <- makeDiv "" $ Cons "output" Nil
    div1 <- makeDiv (prettyPrintType (extractType tt1)) $ Cons "output" Nil
    div2 <- makeDiv (prettyPrintType (extractType tt2)) $ Cons "output" Nil
    div3 <- makeDiv (prettyPrintType t) $ Cons "output" Nil
    arr <- makeDiv " -> " Nil
    arr2 <- makeDiv " -> " Nil
    J.append div1 typContainer
    J.append arr typContainer
    J.append div2 typContainer
    J.append arr2 typContainer
    J.append div3 typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
    jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
    J.append jExp1 subContainer
    J.append jExp2 subContainer
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container
typetoJQuery {typ: TUnary t1 tt t, idTree: IUnary i1 it i} = emptyJQuery --TODO

typetoJQuery {typ: TSectL tt _ _, idTree: ISectL it _ _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}
typetoJQuery {typ: TSectR _ tt _, idTree: ISectR _ it _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}

typetoJQuery {typ: TIfExpr t1 t2 t3 t, idTree: IIfExpr i1 i2 i3 i} = do
    container <- makeDiv "" $ Cons "output" Nil
    div1 <- typetoJQuery {typ:t1,idTree:i1,expr:dummyExpr}
    div2 <- typetoJQuery {typ:t2,idTree:i2,expr:dummyExpr}
    div3 <- typetoJQuery {typ:t3,idTree:i3,expr:dummyExpr}
    J.append div1 container
    J.append div2 container
    J.append div3 container
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return container

typetoJQuery {typ: TLetExpr _ tt1 tt2 t,idTree: ILetExpr _ it1 it2 i} = emptyJQuery --TODO

typetoJQuery {typ: TLambda _ tt t, idTree: ILambda _ it i} = typetoJQuery {typ:tt,idTree:it,expr:dummyExpr}

typetoJQuery {typ:TApp t1 tl t, idTree:IApp i1 is i} = do
    container <- makeDiv "" Nil
    typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv (extractIndex i1)
    list <- mapM (\(Tuple t i) -> (makeDiv (prettyPrintType (extractType t)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex i))) (zip tl is)
    for list $ (\l -> do
                  J.append l typContainer
                  arr <- makeDiv " -> " Nil
                  J.append arr typContainer)
    exprType <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= addTypIdtoDiv i
    J.append exprType typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    divExpr <- typetoJQuery {typ: t1,idTree:i1,expr:dummyExpr}
    J.append divExpr subContainer
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t,idTree:i, expr:dummyExpr}) (zip tl is)
    for list $ (\l -> J.append l subContainer)
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container

typetoJQuery {typ:typ} = emptyJQuery

-- findConnections:: IndexTree -> List Int --TODO

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
  , typetoJQuery
  , idExpr
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.State
import Control.Monad.Eff.Class

import AST
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 isString es of
                  true  -> string es t i
                  false -> 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
    {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 = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t >>= addIdtoDiv i

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
  jLam <- makeDiv "" (singleton "lambda") >>= 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
  return jLam

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 i
  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
  jSect <- makeDiv "" (singleton "section") >>= 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
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  dIf <- makeDiv "" (singleton "if") >>= 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
  return dIf

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
  dtuple <- makeDiv "" (singleton "tuple") >>= 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
  dls <- makeDiv "" (singleton "list") >>= 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
  return dls

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

string :: forall eff. List Expr -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string es t i = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i
  return dstring

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

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
  J.setAttr "title" (prettyPrintType typ) 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

dummyExpr:: Expr
dummyExpr =  Atom $ AInt 0

typetoJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
typetoJQuery {typ:TListTree ls t, idTree: IListTree is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    return $ container
typetoJQuery {typ:TNTuple ls t, idTree: INTuple is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    return $ container
typetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
    container <- makeDiv "" Nil
    typContainer <- makeDiv "" $ Cons "output" Nil
    div1 <- makeDiv (prettyPrintType (extractType tt1)) $ Cons "output" Nil
    div2 <- makeDiv (prettyPrintType (extractType tt2)) $ Cons "output" Nil
    div3 <- makeDiv (prettyPrintType t) $ Cons "output" Nil
    arr <- makeDiv " -> " Nil
    arr2 <- makeDiv " -> " Nil
    J.append div1 typContainer
    J.append arr typContainer
    J.append div2 typContainer
    J.append arr2 typContainer
    J.append div3 typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
    jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
    J.append jExp1 subContainer
    J.append jExp2 subContainer
    J.append subContainer container
typetoJQuery {typ: TUnary t1 tt t, idTree: IUnary i1 it i} = emptyJQuery --TODO

typetoJQuery {typ: TSectL tt _ _, idTree: ISectL it _ _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}
typetoJQuery {typ: TSectR _ tt _, idTree: ISectR _ it _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}

typetoJQuery {typ: TIfExpr t1 t2 t3 t, idTree: IIfExpr i1 i2 i3 i} = do
    container <- makeDiv "" $ Cons "output" Nil
    div1 <- typetoJQuery {typ:t1,idTree:i1,expr:dummyExpr}
    div2 <- typetoJQuery {typ:t2,idTree:i2,expr:dummyExpr}
    div3 <- typetoJQuery {typ:t3,idTree:i3,expr:dummyExpr}
    J.append div1 container
    J.append div2 container
    J.append div3 container

typetoJQuery {typ: TLetExpr _ tt1 tt2 t,idTree: ILetExpr _ it1 it2 i} = emptyJQuery --TODO

typetoJQuery {typ: TLambda _ tt t, idTree: ILambda _ it i} = typetoJQuery {typ:tt,idTree:it,expr:dummyExpr}

typetoJQuery {typ:TApp t1 tl t, idTree:IApp i1 is i} = do
    container <- makeDiv "" Nil
    typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv (extractIndex i1)
    list <- mapM (\(Tuple t i) -> (makeDiv (prettyPrintType (extractType t)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex i))) (zip tl is)
    for list $ (\l -> do
                  J.append l typContainer
                  arr <- makeDiv " -> " Nil
                  J.append arr typContainer)
    exprType <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= addTypIdtoDiv i
    J.append exprType typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    divExpr <- typetoJQuery {typ: t1,idTree:i1,expr:dummyExpr}
    J.append divExpr subContainer
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t,idTree:i, expr:dummyExpr}) (zip tl is)
    for list $ (\l -> J.append l subContainer)
    J.append subContainer container

typetoJQuery {typ:typ} = emptyJQuery

-- findConnections:: IndexTree -> List Int --TODO

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


update for array columns

update for array columns

module Main where

import Control.Monad.Eff
import Debug.Trace
import React
import React.DOM
import Network.XHR
import Data.Maybe
import Data.Either
import Data.Traversable
import Data.Tuple
import Data.Array(head, map)
import Data.JSON((.:), (.:?), decode, FromJSON, parseJSON)
import qualified Data.Map as M

newtype ColumnDetails = ColumnDetails { name::String, kind::String, maxLen:: Maybe Number, nullable::Boolean, position:: Number, updatable:: Boolean, schema:: String, precision:: Maybe Number }

newtype Schema = Schema {pkey :: [String], columns :: [ColumnDetails]}

schema :: [String] -> [ColumnDetails] -> Schema
schema pkey columns = Schema {pkey:pkey, columns:columns}

columnDetails :: String -> String -> Maybe Number -> Boolean -> Number -> Boolean -> String -> Maybe Number -> ColumnDetails
columnDetails name kind maxLen nullable position updatable schma precision = ColumnDetails {name:name, kind:kind, maxLen:maxLen, nullable:nullable, position: position, updatable: updatable, schema: schma, precision: precision}

instance schemaFromJSON :: FromJSON Schema where
  parseJSON (Data.JSON.JObject o) = do
    pkey <- (o .: "pkey")
    columns <- (o .: "columns")
    Right $ schema pkey columns
  parseJSON x = Left "this ain't no schema"

instance columnDetailsFromJSON :: FromJSON ColumnDetails where
  parseJSON (Data.JSON.JObject o) = do
    name <- (o .: "name")
    kind <- (o .: "type")
    maxLen <- (o .:? "maxLen")
    nullable <- (o .: "nullable")
    position <- (o .: "position")
    updatable <- (o .: "updatable")
    schma <- (o .: "schema")
    precision <- (o .:? "precision")
    Right $ columnDetails name kind maxLen nullable position updatable schma precision

httpGet path opts cb = get defaultAjaxOptions
        { onReadyStateChange = onSuccess $ \response -> do
          txt <- getResponseText response
          cb txt
        } path opts

httpOptions path cb = ajax defaultAjaxOptions
        { method = "OPTIONS",
          url = path,
          onReadyStateChange = onSuccess $ \response -> do
          txt <- getResponseText response
          cb txt
        } {} noBody

getSchema url cb = httpOptions url \text -> do
  cb text
  return unit

makeInput x = mkUI spec do
  return $ input [value x] []

makeText x = mkUI spec do
  return $ textarea [value x] []

getComponent :: ColumnDetails -> React.UI
getComponent (ColumnDetails cd) = getCorrectComponent cd.name $ {}
  where
    getCorrectComponent = case cd.kind of
      "character varying" -> makeInput
      "text" -> makeText
      _ -> makeInput

renderComponents :: Schema -> React.UI
renderComponents (Schema x) = div' $ (getComponent <$> x.columns)

createUI :: forall eff. Maybe Schema -> Eff (dom :: React.DOM | eff) React.UI
createUI = renderToBody <<< maybe (div' [text "no go"]) renderComponents

main = do
  getSchema "http://localhost:3000/sessions" (createUI <<< decode)

-- Taken from https://github.com/purescript-contrib/purescript-react/blob/9d93da3a6645be5059c3a499cc71817adfae207e/example/app/app.purs
module Main where

import Control.Monad.Eff
import Debug.Trace
import React
import React.DOM
import Network.XHR
import Data.Maybe
import Data.Either
import Data.Traversable
import Data.Tuple
import Data.Array(head, map)
import Data.JSON((.:), (.:?), decode, FromJSON, parseJSON)
import qualified Data.Map as M

newtype ColumnDetails = ColumnDetails { name::String, kind::String, maxLen:: Maybe Number, nullable::Boolean, position:: Number, updatable:: Boolean, schema:: String, precision:: Maybe Number }

type Columns = (M.Map String ColumnDetails)

newtype Schema = Schema {pkey :: [String], columns :: Columns}

schema :: [String] -> Columns -> Schema
schema pkey columns = Schema {pkey:pkey, columns:columns}

columnDetails :: String -> String -> Maybe Number -> Boolean -> Number -> Boolean -> String -> Maybe Number -> ColumnDetails
columnDetails name kind maxLen nullable position updatable schma precision = ColumnDetails {name:name, kind:kind, maxLen:maxLen, nullable:nullable, position: position, updatable: updatable, schema: schma, precision: precision}

instance schemaFromJSON :: FromJSON Schema where
  parseJSON (Data.JSON.JObject o) = do
    pkey <- (o .: "pkey")
    columns <- (o .: "columns")
    Right $ schema pkey columns
  parseJSON x = Left "this ain't no schema"

instance columnsFromJSON :: FromJSON (M.Map String ColumnDetails) where
  parseJSON (Data.JSON.JObject obj) = M.fromList <$> traverse go (M.toList obj)
    where
      go (Tuple s r) = (Tuple s) <$> (parseJSON r)

instance columnDetailsFromJSON :: FromJSON ColumnDetails where
  parseJSON (Data.JSON.JObject o) = do
    name <- (o .: "name")
    kind <- (o .: "type")
    maxLen <- (o .:? "maxLen")
    nullable <- (o .: "nullable")
    position <- (o .: "position")
    updatable <- (o .: "updatable")
    schma <- (o .: "schema")
    precision <- (o .:? "precision")
    Right $ columnDetails name kind maxLen nullable position updatable schma precision

httpGet path opts cb = get defaultAjaxOptions
        { onReadyStateChange = onSuccess $ \response -> do
          txt <- getResponseText response
          cb txt
        } path opts

httpOptions path cb = ajax defaultAjaxOptions
        { method = "OPTIONS",
          url = path,
          onReadyStateChange = onSuccess $ \response -> do
          txt <- getResponseText response
          cb txt
        } {} noBody

getSchema url cb = httpOptions url \text -> do
  cb text
  return unit

columnList :: Schema -> [ColumnDetails]
columnList (Schema x) = snd <$> (M.toList x.columns)

makeInput x = mkUI spec do
  return $ input [value x] []

makeText x = mkUI spec do
  return $ textarea [value x] []

getComponent :: ColumnDetails -> React.UI
getComponent (ColumnDetails cd) = case cd.kind of
  "character varying" -> makeInput cd.name $ {}
  "text" -> makeText cd.name $ {}
  _ -> makeInput cd.name $ {}

renderComponents :: Schema -> React.UI
renderComponents x = div' $ (getComponent <$> columnList x)

createUI :: forall eff. Maybe Schema -> Eff (dom :: React.DOM | eff) React.UI
createUI = renderToBody <<< maybe (div' [text "no go"]) renderComponents

main = do
  getSchema "http://localhost:3000/sessions" (createUI <<< decode)


Changed to 'answerCount'

Changed to 'answerCount'

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

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

type State = { all :: Countries, current :: Array String, correct :: Number, incorrect :: Number }
type Countries = Array Country
data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | ReceiveAnswer String | ReceiveAnswers (Array String)
newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

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

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

answerCount :: Int
answerCount = 4

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

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

fetch :: forall e. Aff (ajax :: AJAX | e) (Tuple Countries (Array String))
fetch = get "/countries.json" >>= \xs -> case decode xs of
  Left _          -> pure $ Tuple [] []
  Right countries -> pure $ Tuple countries (randomise countries)

randomise :: Countries -> Array String
randomise xs = take answerCount $ _.name <<< unwrap <$> xs

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

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

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

import Control.Monad.Aff (Aff)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (length, uncons, head, take, drop)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Int (fromNumber, round)
import Data.Tuple (Tuple(..))
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)

answers :: Int
answers = 4

type State = { all :: Countries, current :: Array String, correct :: Number, incorrect :: Number }
type Countries = Array Country
data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | ReceiveAnswer String | ReceiveAnswers (Array String)
newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

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

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

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

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

fetch :: forall e. Aff (ajax :: AJAX | e) (Tuple Countries (Array String))
fetch = get "/countries.json" >>= \xs -> case decode xs of
  Left _          -> pure $ Tuple [] []
  Right countries -> pure $ Tuple countries (randomise countries)

randomise :: Countries -> Array String
randomise xs = take answers $ _.name <<< unwrap <$> xs

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

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


trace is now called log

trace is now called log

module Main where

import Prelude

import Data.Array
import Data.Maybe

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

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Events
import Data.DOM.Simple.Navigator
import qualified Data.DOM.Simple.NodeList as NL

import Test.QuickCheck

foreign import inspect :: forall a. a -> Unit

foreign import tagname :: forall a. a -> String

checkTagName shouldBe element = do
  let name = tagname element
  quickCheck' 1 $ name == shouldBe

checkContents shouldBe element = do
  contents <- textContent (element :: HTMLElement)
  quickCheck' 1 $ contents == shouldBe

checkValue shouldBe element = do
  val <- value (element :: HTMLElement)
  quickCheck' 1 $ val == shouldBe

main = do
  doc <- document globalWindow

  log "Able to get the title of a document"

  docTitle <- title doc
  quickCheck' 1 $ docTitle == "testTitle"

  -- attrib <- "#testDiv1" `getAttribute` "hello"

  log "Able to set the title of a document"

  setTitle "modifiedTitle" doc
  docTitle1 <- title doc

  quickCheck' 1 $ docTitle1 == "modifiedTitle"

  log "Able to get the body element of a document"

  docBody <- body doc

  checkTagName "BODY" docBody

  log "Able to look up elements"

  Just testDiv1 <- getElementById "test1" doc

  checkTagName "DIV" testDiv1
  checkContents "testContent1" testDiv1

  Just testDiv2 <- querySelector ".test2" doc

  checkTagName "DIV" testDiv2
  checkContents "testContent2" testDiv2

  Just testDiv3 <- querySelector "test3" doc

  checkTagName "TEST3" testDiv3
  checkContents "testContent3" testDiv3

  testDivs <- querySelectorAll "div" doc

  log "Able to count items in a nodelist"
  NL.length testDivs >>= (\len -> quickCheck' 1 $ len == 2)

  log "Able to retrieve an item from a nodelist"
  Just testDiv4 <- NL.item 0 testDivs
  checkTagName "DIV" testDiv4

  log "Able to convert a nodelist into an array"
  nl1 <- NL.nodeListToArray testDivs
  nl2 <- NL.nodeListToArray' testDivs
  quickCheck' 1 $ length nl1 == length nl2

  log "Able to modify an elements contents"

  setTextContent "Hello" testDiv1

  checkContents "Hello" testDiv1

  log "Able to modify a form element's value"

  Just testInput1 <- getElementById "input1" doc

  setValue "foo bar baz" testInput1

  checkValue "foo bar baz" testInput1

  log "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  log "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false

  log "Able to set a style attribute on an element"

  setStyleAttr "color" "red" testDiv1
  testDiv1StyleAttr <- getStyleAttr "color" testDiv1

  quickCheck' 1 $ testDiv1StyleAttr == "red"

  navigator <- navigator globalWindow
  log "Able to receive the appName from navigator"
  appName navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  log "Able to receive the appVersion from navigator"
  appVersion navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  log "Able to receive the language from navigator"
  language navigator >>= (\name -> quickCheck' 1 $ name == "en-US")

  log "Able to append a child"
  appendChild docBody testDiv1

  -- Tests for offset* properties of an element. These behave strangely
  -- with Zombie.js, so these tests just ensure that a value is returned.

  log "Able to get the offsetParent of an element"
  -- HTMLElement.offsetParent is "undefined" in Zombie.js
  noParent <- offsetParent testDiv1
  quickCheck' 1 $ isNothing noParent

  log "Able to get the offsetHeight of an element"
  heightVal <- offsetHeight testDiv1
  quickCheck' 1 $ heightVal == 0

  log "Able to get the offsetWidth of an element"
  widthVal <- offsetWidth testDiv1
  quickCheck' 1 $ widthVal == 0

  log "Able to get the offsetTop of an element"
  topVal <- offsetTop testDiv1
  quickCheck' 1 $ topVal == 0

  log "Able to get the offsetLeft of an element"
  leftVal <- offsetLeft testDiv1
  quickCheck' 1 $ leftVal == 0

  -- Unavailable in Zombie
  -- log "Able to add a class"

  --hasTestClass1 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass1 == false

  -- classAdd "testClass" testDiv1
  -- hasTestClass2 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass2 == true

module Main where

import Prelude

import Data.Array
import Data.Maybe

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

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Events
import Data.DOM.Simple.Navigator
import qualified Data.DOM.Simple.NodeList as NL

import Test.QuickCheck

foreign import inspect :: forall a. a -> Unit

foreign import tagname :: forall a. a -> String

checkTagName shouldBe element = do
  let name = tagname element
  quickCheck' 1 $ name == shouldBe

checkContents shouldBe element = do
  contents <- textContent (element :: HTMLElement)
  quickCheck' 1 $ contents == shouldBe

checkValue shouldBe element = do
  val <- value (element :: HTMLElement)
  quickCheck' 1 $ val == shouldBe

main = do
  doc <- document globalWindow

  log "Able to get the title of a document"

  docTitle <- title doc
  quickCheck' 1 $ docTitle == "testTitle"

  -- attrib <- "#testDiv1" `getAttribute` "hello"

  log "Able to set the title of a document"

  setTitle "modifiedTitle" doc
  docTitle1 <- title doc

  quickCheck' 1 $ docTitle1 == "modifiedTitle"

  log "Able to get the body element of a document"

  docBody <- body doc

  checkTagName "BODY" docBody

  log "Able to look up elements"

  Just testDiv1 <- getElementById "test1" doc

  checkTagName "DIV" testDiv1
  checkContents "testContent1" testDiv1

  Just testDiv2 <- querySelector ".test2" doc

  checkTagName "DIV" testDiv2
  checkContents "testContent2" testDiv2

  Just testDiv3 <- querySelector "test3" doc

  checkTagName "TEST3" testDiv3
  checkContents "testContent3" testDiv3

  testDivs <- querySelectorAll "div" doc

  log "Able to count items in a nodelist"
  NL.length testDivs >>= (\len -> quickCheck' 1 $ len == 2)

  log "Able to retrieve an item from a nodelist"
  Just testDiv4 <- NL.item 0 testDivs
  checkTagName "DIV" testDiv4

  log "Able to convert a nodelist into an array"
  nl1 <- NL.nodeListToArray testDivs
  nl2 <- NL.nodeListToArray' testDivs
  quickCheck' 1 $ length nl1 == length nl2

  log "Able to modify an elements contents"

  setTextContent "Hello" testDiv1

  checkContents "Hello" testDiv1

  log "Able to modify a form element's value"

  Just testInput1 <- getElementById "input1" doc

  setValue "foo bar baz" testInput1

  checkValue "foo bar baz" testInput1

  log "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  log "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false

  log "Able to set a style attribute on an element"

  setStyleAttr "color" "red" testDiv1
  testDiv1StyleAttr <- getStyleAttr "color" testDiv1

  quickCheck' 1 $ testDiv1StyleAttr == "red"

  navigator <- navigator globalWindow
  log "Able to receive the appName from navigator"
  appName navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  log "Able to receive the appVersion from navigator"
  appVersion navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  log "Able to receive the language from navigator"
  language navigator >>= (\name -> quickCheck' 1 $ name == "en-US")

  log "Able to append a child"
  appendChild docBody testDiv1

  -- Tests for offset* properties of an element. These behave strangely
  -- with Zombie.js, so these tests just ensure that a value is returned.

  trace "Able to get the offsetParent of an element"
  -- HTMLElement.offsetParent is "undefined" in Zombie.js
  noParent <- offsetParent testDiv1
  quickCheck' 1 $ isNothing noParent

  trace "Able to get the offsetHeight of an element"
  heightVal <- offsetHeight testDiv1
  quickCheck' 1 $ heightVal == 0

  trace "Able to get the offsetWidth of an element"
  widthVal <- offsetWidth testDiv1
  quickCheck' 1 $ widthVal == 0

  trace "Able to get the offsetTop of an element"
  topVal <- offsetTop testDiv1
  quickCheck' 1 $ topVal == 0

  trace "Able to get the offsetLeft of an element"
  leftVal <- offsetLeft testDiv1
  quickCheck' 1 $ leftVal == 0

  -- Unavailable in Zombie
  -- log "Able to add a class"

  --hasTestClass1 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass1 == false

  -- classAdd "testClass" testDiv1
  -- hasTestClass2 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass2 == true


Fix argument order of scroll property setters

module DOM.Node.Element where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Nullable (Nullable)
import DOM (DOM)
import DOM.Node.Types (Element, HTMLCollection, ElementId)

foreign import namespaceURI :: Element -> Nullable String
foreign import prefix :: Element -> Nullable String
foreign import localName :: Element -> String
foreign import tagName :: Element -> String

foreign import id :: forall eff. Element -> Eff (dom :: DOM | eff) ElementId
foreign import setId :: forall eff. ElementId -> Element -> Eff (dom :: DOM | eff) Unit
foreign import className :: forall eff. Element -> Eff (dom :: DOM | eff) String
foreign import setClassName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) Unit

foreign import getElementsByTagName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) HTMLCollection
foreign import getElementsByTagNameNS :: forall eff. Nullable String -> String -> Element -> Eff (dom :: DOM | eff) HTMLCollection
foreign import getElementsByClassName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) HTMLCollection

foreign import setAttribute :: forall eff. String -> String -> Element -> Eff (dom :: DOM | eff) Unit
foreign import getAttribute :: forall eff. String -> Element -> Eff (dom :: DOM | eff) (Nullable String)
foreign import removeAttribute :: forall eff. String -> Element -> Eff (dom :: DOM | eff) Unit

foreign import scrollTop :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import setScrollTop :: forall eff. Number -> Element -> Eff (dom :: DOM | eff) Unit

foreign import scrollLeft :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import setScrollLeft :: forall eff. Number -> Element -> Eff (dom :: DOM | eff) Unit

foreign import scrollWidth :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import scrollHeight :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientTop :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientLeft :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientWidth :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientHeight :: forall eff. Element -> Eff (dom :: DOM | eff) Number

module DOM.Node.Element where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Nullable (Nullable)
import DOM (DOM)
import DOM.Node.Types (Element, HTMLCollection, ElementId)

foreign import namespaceURI :: Element -> Nullable String
foreign import prefix :: Element -> Nullable String
foreign import localName :: Element -> String
foreign import tagName :: Element -> String

foreign import id :: forall eff. Element -> Eff (dom :: DOM | eff) ElementId
foreign import setId :: forall eff. ElementId -> Element -> Eff (dom :: DOM | eff) Unit
foreign import className :: forall eff. Element -> Eff (dom :: DOM | eff) String
foreign import setClassName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) Unit

foreign import getElementsByTagName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) HTMLCollection
foreign import getElementsByTagNameNS :: forall eff. Nullable String -> String -> Element -> Eff (dom :: DOM | eff) HTMLCollection
foreign import getElementsByClassName :: forall eff. String -> Element -> Eff (dom :: DOM | eff) HTMLCollection

foreign import setAttribute :: forall eff. String -> String -> Element -> Eff (dom :: DOM | eff) Unit
foreign import getAttribute :: forall eff. String -> Element -> Eff (dom :: DOM | eff) (Nullable String)
foreign import removeAttribute :: forall eff. String -> Element -> Eff (dom :: DOM | eff) Unit

foreign import scrollTop :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import setScrollTop :: forall eff. Element -> Number -> Eff (dom :: DOM | eff) Unit

foreign import scrollLeft :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import setScrollLeft :: forall eff. Element -> Number -> Eff (dom :: DOM | eff) Unit

foreign import scrollWidth :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import scrollHeight :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientTop :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientLeft :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientWidth :: forall eff. Element -> Eff (dom :: DOM | eff) Number
foreign import clientHeight :: forall eff. Element -> Eff (dom :: DOM | eff) Number


Add selected city.

Add selected city.

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, getValue, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F, readString)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"
  citiesSelect <- select "#selectCityToAdd"
  body <- body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body
  on' "click" "#butAddCancel" (\_ _ -> toggleAddDialog false addDialog) body
  on' "click" "#butAddCity" (\_ _ -> addSelectedCity stateRef citiesSelect addDialog) body

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else do
      setText cardData.created cardLastUpdatedElem
      find "> .location" card >>= setText cardData.label
      find "> .description" card >>= setText current.text
      find "> .date" card >>= setText current.date
      find ".current .icon" card >>= setClass (getIconClass current.code) true
      find ".current .temperature .value" card >>= (setText $ show current.temp)
      find ".current .sunrise" card >>= setText astronomy.sunrise
      find ".current .sunset" card >>= setText astronomy.sunset
      find ".current .humidity" card >>= (setText $ show humidity <> "%")
      find ".current .wind .value" card >>= (setText $ show wind.speed)
      find ".current .wind .direction" card >>= (setText $ show wind.direction)

      nextDays <- find ".future .oneday" card >>= toArray
      ndw <- nextDaysOfWeek
      foreachE (zip3 nextDays forcast ndw) updateNextDay

      AppState state <- readRef stateRef
      when state.isLoading do
        hide state.spinner
        modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

      where
        channel = cardData.channel
        astronomy = channel.astronomy
        current = channel.item.condition
        forcast = channel.item.forecast
        humidity = channel.atmosphere.humidity
        wind = channel.wind

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t = do
  find ".icon" c >>= setClass (getIconClass daily.code) true
  find ".date" c >>= setText wd
  find ".temp-high .value" c >>= (setText $ show daily.high)
  find ".temp-low .value" c >>= (setText $ show daily.low)
  where
    c = get1 t
    daily = get2 t
    wd = get3 t

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

addSelectedCity :: forall e
   . Ref AppState
  -> JQuery
  -> JQuery
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
addSelectedCity stateRef citiesSelect addDialog = do
  selectedOpt <- find "option:selected" citiesSelect
  label <- getText selectedOpt
  value <- getValue selectedOpt
  case runExcept $ readString value of
    Left err -> log $ show err
    Right key -> do
      getForecast stateRef key label
      toggleAddDialog false addDialog

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Network.HTTP.Affjax (AJAX, get)
import Partial.Unsafe (unsafePartial)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  card <- getOrCreateCard stateRef cardData.key
  cardLastUpdatedElem <- find "> .card-last-updated" card
  cardLastUpdatedStr <- getText cardLastUpdatedElem

  dataIsOld <- if cardLastUpdatedStr == ""
    then pure false
    else do
      dataLastUpdatedJSDate <- parse cardData.created
      cardLastUpdatedJSDate <- parse cardLastUpdatedStr
      let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
      let cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
      pure $ cardLastUpdated > dataLastUpdated

  if dataIsOld
    then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
    else
      let channel = cardData.channel
          astronomy = channel.astronomy
          current = channel.item.condition
          forcast = channel.item.forecast
          humidity = channel.atmosphere.humidity
          wind = channel.wind
      in do
        setText cardData.created cardLastUpdatedElem
        find "> .location" card >>= setText cardData.label
        find "> .description" card >>= setText current.text
        find "> .date" card >>= setText current.date
        find ".current .icon" card >>= setClass (getIconClass current.code) true
        find ".current .temperature .value" card >>= (setText $ show current.temp)
        find ".current .sunrise" card >>= setText astronomy.sunrise
        find ".current .sunset" card >>= setText astronomy.sunset
        find ".current .humidity" card >>= (setText $ show humidity <> "%")
        find ".current .wind .value" card >>= (setText $ show wind.speed)
        find ".current .wind .direction" card >>= (setText $ show wind.direction)

        nextDays <- find ".future .oneday" card >>= toArray
        ndw <- nextDaysOfWeek
        foreachE (zip3 nextDays forcast ndw) updateNextDay

        AppState state <- readRef stateRef
        when state.isLoading do
          hide state.spinner
          modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in do
    find ".icon" c >>= setClass (getIconClass daily.code) true
    find ".date" c >>= setText wd
    find ".temp-high .value" c >>= (setText $ show daily.high)
    find ".temp-low .value" c >>= (setText $ show daily.low)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }


mouseButtonPressed translated to Effect

mouseButtonPressed translated to Effect

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , mouseButtonPressed
  , touch
  , tap
  , mousePos
  , windowDimensions
  , CoordinatePair(..)
  , DimensionPair(..)
  , Touch(..)
  , MouseButton (..)
  ) where

import Effect (Effect)
import Prelude (($), bind, pure)
import Signal (constant, Signal, (~>))
import Signal.Time (now, Time)

type CoordinatePair = { x :: Int, y :: Int }
type DimensionPair  = { w :: Int, h :: Int }
data MouseButton = MouseLeftButton | MouseMiddleButton | MouseIE8MiddleButton | MouseRightButton

foreign import keyPressedP :: forall c. (c -> Signal c) -> Int -> Effect (Signal Boolean)

-- |Creates a signal which will be `true` when the key matching the given key
-- |code is pressed, and `false` when it's released.
keyPressed :: Int -> Effect (Signal Boolean)
keyPressed = keyPressedP constant

foreign import mouseButtonP :: forall c. (c -> Signal c) -> Int -> Effect (Signal Boolean)

-- |Creates a signal which will be `true` when the given mouse button is
-- |pressed, and `false` when it's released.
mouseButton :: Int -> Effect(Signal Boolean)
mouseButton = mouseButtonP constant

-- |Creates a signal which will be `true` when the given mouse button is
-- |pressed, and `false` when it's released.
-- |note: in IE8 and earlier you need to use MouseIE8MiddleButton if you want to query the middle button
mouseButtonPressed :: MouseButton -> Effect (Signal Boolean)
mouseButtonPressed btn = mouseButton buttonNumber
  where
    buttonNumber = case btn of
      MouseLeftButton      -> 0
      MouseRightButton     -> 2
      MouseMiddleButton    -> 1
      MouseIE8MiddleButton -> 4

type Touch = { id :: String
             , screenX :: Int, screenY :: Int
             , clientX :: Int, clientY :: Int
             , pageX :: Int, pageY :: Int
             , radiusX :: Int, radiusY :: Int
             , rotationAngle :: Number, force :: Number }

foreign import touchP :: forall c. (c -> Signal c) -> Effect (Signal (Array Touch))

-- |A signal containing the current state of the touch device, as described by
-- |the `Touch` record type.
touch :: Effect (Signal (Array Touch))
touch = touchP constant

-- |A signal which will be `true` when at least one finger is touching the
-- |touch device, and `false` otherwise.
tap :: Effect (Signal Boolean)
tap = do
  touches <- touch
  pure $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP :: forall c. (c -> Signal c) -> Effect (Signal CoordinatePair)

-- |A signal containing the current mouse position.
mousePos :: Effect (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP :: forall c. (c -> Signal c) -> Effect Time -> Effect (Signal Time)

-- |A signal which yields the current time, as determined by `now`, on every
-- |animation frame (see [https://developer.mozilla.org/en-US/docs/Web/API/window/requestAnimationFrame]).
animationFrame :: Effect (Signal Time)
animationFrame = animationFrameP constant now

foreign import windowDimensionsP :: forall c. (c -> Signal c) -> Effect (Signal DimensionPair)

-- |A signal which contains the document window's current width and height.
windowDimensions :: Effect (Signal DimensionPair)
windowDimensions = windowDimensionsP constant

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , mouseButtonPressed
  , touch
  , tap
  , mousePos
  , windowDimensions
  , CoordinatePair(..)
  , DimensionPair(..)
  , Touch(..)
  , MouseButton (..)
  ) where

import Effect (Effect)
import Prelude (($), bind, pure)
import Signal (constant, Signal, (~>))
import Signal.Time (now, Time)

type CoordinatePair = { x :: Int, y :: Int }
type DimensionPair  = { w :: Int, h :: Int }
data MouseButton = MouseLeftButton | MouseMiddleButton | MouseIE8MiddleButton | MouseRightButton

foreign import keyPressedP :: forall c. (c -> Signal c) -> Int -> Effect (Signal Boolean)

-- |Creates a signal which will be `true` when the key matching the given key
-- |code is pressed, and `false` when it's released.
keyPressed :: Int -> Effect (Signal Boolean)
keyPressed = keyPressedP constant

foreign import mouseButtonP :: forall c. (c -> Signal c) -> Int -> Effect (Signal Boolean)

-- |Creates a signal which will be `true` when the given mouse button is
-- |pressed, and `false` when it's released.
mouseButton :: Int -> Effect(Signal Boolean)
mouseButton = mouseButtonP constant

-- |Creates a signal which will be `true` when the given mouse button is
-- |pressed, and `false` when it's released.
-- |note: in IE8 and earlier you need to use MouseIE8MiddleButton if you want to query the middle button
mouseButtonPressed :: forall e. MouseButton -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButtonPressed btn = mouseButton buttonNumber
  where
    buttonNumber = case btn of
      MouseLeftButton      -> 0
      MouseRightButton     -> 2
      MouseMiddleButton    -> 1
      MouseIE8MiddleButton -> 4

type Touch = { id :: String
             , screenX :: Int, screenY :: Int
             , clientX :: Int, clientY :: Int
             , pageX :: Int, pageY :: Int
             , radiusX :: Int, radiusY :: Int
             , rotationAngle :: Number, force :: Number }

foreign import touchP :: forall c. (c -> Signal c) -> Effect (Signal (Array Touch))

-- |A signal containing the current state of the touch device, as described by
-- |the `Touch` record type.
touch :: Effect (Signal (Array Touch))
touch = touchP constant

-- |A signal which will be `true` when at least one finger is touching the
-- |touch device, and `false` otherwise.
tap :: Effect (Signal Boolean)
tap = do
  touches <- touch
  pure $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP :: forall c. (c -> Signal c) -> Effect (Signal CoordinatePair)

-- |A signal containing the current mouse position.
mousePos :: Effect (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP :: forall c. (c -> Signal c) -> Effect Time -> Effect (Signal Time)

-- |A signal which yields the current time, as determined by `now`, on every
-- |animation frame (see [https://developer.mozilla.org/en-US/docs/Web/API/window/requestAnimationFrame]).
animationFrame :: Effect (Signal Time)
animationFrame = animationFrameP constant now

foreign import windowDimensionsP :: forall c. (c -> Signal c) -> Effect (Signal DimensionPair)

-- |A signal which contains the document window's current width and height.
windowDimensions :: Effect (Signal DimensionPair)
windowDimensions = windowDimensionsP constant


Remove unused import

Remove unused import

module Test.Spec.Console
  ( setAttr
  , reset
  , withAttrs
  ) where

import Prelude

import Control.Monad.Eff         (Eff())
import Control.Monad.Eff.Console (CONSOLE)
import Data.Foldable             (foldr)

-- This needs a foreign function to support the escape sequence.
foreign import _setAttr :: forall e. String -> Eff (console :: CONSOLE | e) Unit

setAttr :: forall e. Int -> Eff (console :: CONSOLE | e) Unit
setAttr code = _setAttr (show code)

reset :: forall e. Eff (console :: CONSOLE | e) Unit
reset = setAttr 0

withAttrs :: forall r. (Array Int)
          -> Eff (console :: CONSOLE | r) Unit
          -> Eff (console :: CONSOLE | r) Unit
withAttrs as r = foldr iter r as
  where iter attr acc = setAttr attr *> acc *> reset

module Test.Spec.Console
  ( setAttr
  , reset
  , withAttrs
  ) where

import Prelude

import Control.Apply             ((*>))
import Control.Monad.Eff         (Eff())
import Control.Monad.Eff.Console (CONSOLE)
import Data.Foldable             (foldr)

-- This needs a foreign function to support the escape sequence.
foreign import _setAttr :: forall e. String -> Eff (console :: CONSOLE | e) Unit

setAttr :: forall e. Int -> Eff (console :: CONSOLE | e) Unit
setAttr code = _setAttr (show code)

reset :: forall e. Eff (console :: CONSOLE | e) Unit
reset = setAttr 0

withAttrs :: forall r. (Array Int)
          -> Eff (console :: CONSOLE | r) Unit
          -> Eff (console :: CONSOLE | r) Unit
withAttrs as r = foldr iter r as
  where iter attr acc = setAttr attr *> acc *> reset


Expand STArray example

Expand STArray example

module Main where

import Prelude
import Eff
import ST
import Arrays

test = runSTArray (do
  a <- newSTArray 2 0
  pokeSTArray a 0 1
  pokeSTArray a 1 2
  return a)

fromTo' lo hi _ arr | lo > hi = return arr
fromTo' lo hi i arr = do
  pokeSTArray arr i lo
  fromTo' (lo + 1) hi (i + 1) arr

fromTo lo hi = runSTArray (do
  arr <- newSTArray (hi - lo + 1) 0
  fromTo' lo hi 0 arr)

main = Trace.print $ runPure (fromTo 10 20)

module Main where

import Prelude
import Eff
import ST
import Arrays

test = runSTArray (do
  a <- newSTArray 2 0
  pokeSTArray a 0 1
  pokeSTArray a 1 2
  return a)

main = Trace.print $ runPure test