Handle missing properties of classes as IRNull

Original commit d27d6d5a4f7234ed6acfb805540aa9131635d2f7

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (find)
import Data.Maybe (Maybe(..))

import Data.List ((:))
import Data.List as L
import Data.Tuple as Tuple
import Data.List.Types (List(..))
import Data.StrMap as StrMap
import Data.Map as Map
import Data.Foldable (for_)
import Data.Set as S

import IR

import Doc (Doc())
import Doc as Doc

import Swift as Swift
import CSharp as CSharp

type Renderer = IRClassData -> Doc Unit

renderers = {
    csharp: CSharp.renderCSharpClass --, swift: Swift.renderSwiftClass
}

lookupOrDefault :: forall k v. Ord k => v -> k -> Map.Map k v -> v
lookupOrDefault default key m =
    case Map.lookup key m of
    Nothing -> default
    Just x -> x

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> v) -> v -> Map.Map k v -> Map.Map k v -> Map.Map k v
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ Map.keys m1) (S.fromFoldable $ Map.keys m2)
        valueFor k = (unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2))
        kvps = map (\k -> Tuple.Tuple k (valueFor k)) allKeys
    in
        Map.fromFoldable kvps

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses { name: na, properties: pa } { name: nb, properties: pb } =
    { name: na, properties: unionWithDefault unifyTypesWithNull IRNothing pa pb }

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { element: arrayA, rest: sa } = removeElement isArray sa
        { element: arrayB, rest: sb } = removeElement isArray sb
        { element: classA, rest: sa } = removeElement isClass sa
        { element: classB, rest: sb } = removeElement isClass sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> IRType
unifyTypesWithNull IRNothing IRNothing = IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (\arr -> let singular = singularize name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson singular j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass { name, properties: Map.fromFoldable $ StrMap.foldMap toProperty obj }
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls -> cls : L.concatMap gatherClassesFromType (Map.values cls.properties)
    IRArray t -> gatherClassesFromType t
    _ -> empty

renderClasses :: Renderer -> L.List IRClassData -> Doc Unit
renderClasses renderer classes = for_ classes \cls -> do
    renderer cls
    Doc.blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClasses renderers.csharp
    <#> Doc.render

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (find)
import Data.Maybe (Maybe(..))

import Data.List ((:))
import Data.List as L
import Data.Tuple as Tuple
import Data.List.Types (List(..))
import Data.StrMap as StrMap
import Data.Map as Map
import Data.Foldable (for_)
import Data.Set as S

import IR

import Doc (Doc())
import Doc as Doc

import Swift as Swift
import CSharp as CSharp

type Renderer = IRClassData -> Doc Unit

renderers = {
    csharp: CSharp.renderCSharpClass,
    swift: Swift.renderSwiftClass
}

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses { name: na, properties: pa } { name: nb, properties: pb } =
    { name: na, properties: Map.unionWith unifyTypes pa pb }

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { element: arrayA, rest: sa } = removeElement isArray sa
        { element: arrayB, rest: sb } = removeElement isArray sb
        { element: classA, rest: sa } = removeElement isClass sa
        { element: classB, rest: sb } = removeElement isClass sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (\arr -> let singular = singularize name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson singular j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass { name, properties: Map.fromFoldable $ StrMap.foldMap toProperty obj }
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls -> cls : L.concatMap gatherClassesFromType (Map.values cls.properties)
    IRArray t -> gatherClassesFromType t
    _ -> empty

renderClasses :: Renderer -> L.List IRClassData -> Doc Unit
renderClasses renderer classes = for_ classes \cls -> do
    renderer cls
    Doc.blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClasses renderers.csharp
    <#> Doc.render


modified parseExpr to use pass the next free index it got from the parser

module Main where

import AST as AST
import Parser as Parser
import Evaluator as Eval
import Web as Web
import TypeChecker as TypeChecker
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (empty)
import Data.Array (cons)
import Data.Traversable (for)
import Data.Tuple (Tuple (..))

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

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
makeCE input selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \(Tuple expr nextIdx) -> do
    let env = preludeEnv
    showExprIn expr env [] container Nothing
    pure unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
makeCEwithDefs input defs selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \(Tuple expr nextIdx)-> do
    let env = stringToEnv defs
    showExprIn expr env [] container Nothing

makeCEwithHistory :: forall eff. String -> String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
makeCEwithHistory input selector histSelector = do
  clearInfo
  container <- J.select selector
  histContainer <- J.select histSelector
  doWithJust (parseExpr input) \(Tuple expr nextIdx) -> do
    let env = preludeEnv
    showExprIn expr env [] container (Just histContainer)

makeCEwithDefsAndHistory :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
makeCEwithDefsAndHistory  input defs selector histSelector = do
  clearInfo
  container <- J.select selector
  histContainer <- J.select histSelector
  doWithJust (parseExpr input) \(Tuple expr nextIdx) -> do
    let env = stringToEnv defs
    showExprIn expr env [] container (Just histContainer)

-- | Try to parse the given expression and report parser errors.
parseExpr :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe (Tuple AST.TypeTree Int))
parseExpr input = case Parser.parseExpr input of
  Left error -> do
    showError "Parser" (show error)
    pure Nothing
  Right (Tuple expr nextIdx)-> pure $ Just (Tuple expr idx)

eval1 :: Eval.Env -> AST.TypeTree -> Either String AST.TypeTree
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left err    -> Left $ show err
  Right expr' -> Right expr'

eval1' :: Eval.Env -> AST.TypeTree -> AST.TypeTree
eval1' env expr = case eval1 env expr of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> Array AST.TypeTree -> J.JQuery -> Maybe J.JQuery-> Web.Callback
makeCallback env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1'
  case getType event of
    "click"     -> if evalFunc env expr /= expr
                   then showExprIn (hole (evalFunc env expr)) env (cons (hole expr) history) container histContainer
                   else pure unit
    "mouseover" -> do
                     log $ show expr
                     case eval1 env expr of
                       Right expr' -> do
                         log $ show expr'
                         J.addClass "highlight" jq
                       Left err   -> log err
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

exprToJQuery :: forall eff. Web.Callback -> AST.TypeTree -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery true callback

-- | Clear the contents of info div.
clearInfo :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
clearInfo = void $ J.select "#info" >>= J.clear

-- | Create an info div and display an error inside.
showError :: forall eff. String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
showError origin msg = do
  info <- do
    paragraph <- J.create "

"
    J.addClass "info" paragraph
    J.setText ("Error in " <> origin <> " => " <> msg) paragraph
    pure paragraph
  clearInfo
  infoDiv <- J.select "#info"
  J.append info infoDiv

-- | Execute the given function if the given maybe (wrapped inside an effect) is a `Just x` value
-- | using `x` as the argument. If the maybe is `Nothing` don't do anything.
doWithJust :: forall a eff. Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe a)
         -> (a -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)
         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
doWithJust mMaybe f = do
  mValue <- mMaybe
  case mValue of
    Nothing -> pure unit
    Just x  -> f x

-- | Given an evaluation environment, try to infer the types inside of it.
buildTypeEnvironment :: Partial => Eval.Env -> Maybe TypeChecker.TypeEnv
buildTypeEnvironment env =
  let defs = Eval.envToDefs env
  in case TypeChecker.tryInferEnvironment defs of
    Left error -> Nothing
    Right typedEnv -> Just typedEnv

-- | Type check an expression using a given typed environment.
-- | Construct a div tree from the given typed expression.
typeCheckExpression :: forall eff. Partial => TypeChecker.TypeEnv -> AST.TypeTree
                 -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe AST.TypeTree)
typeCheckExpression typedEnv expr = do
  case TypeChecker.runInferWith typedEnv false (TypeChecker.inferExpr expr) of
    Left typeError -> do
      showError "Expression" (AST.prettyPrintTypeError typeError)
      pure Nothing
    Right typedExpr -> do
      pure $ Just typedExpr

-- | Construct a div tree from the given typed expression.
buildDivTreeFromExpression :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree
                           -> J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
buildDivTreeFromExpression typedExpr env history container histContainer = do
    content <- exprToJQuery (makeCallback env history container histContainer) typedExpr
    J.clear container
    J.append content container
    case histContainer of
      Nothing -> pure unit
      Just histContainer -> do
        J.clear histContainer
        for history $ \typedExpr -> do
          histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) typedExpr
          histDiv <- J.create "

"
          J.addClass "history-element" histDiv
          J.append histExpr histDiv
          J.append histDiv histContainer
        pure unit
    pure unit

-- | Show the given expression inside a given environment after the types of the environment as
-- | well as the expression have been inferred.
showExprIn :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree -> J.JQuery
           -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
showExprIn expr env history container histContainer = do
  -- Try to infer the types of the environment.
  -- doWithJust (buildTypeEnvironment expr env) \typedEnv -> do
    -- Try to infer the type of the given expression.
    -- doWithJust (typeCheckExpression preludeTyped expr) \typedExpr ->
      -- buildDivTreeFromExpression typedExpr env history container histContainer
    buildDivTreeFromExpression expr env history container histContainer

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right (Tuple defs _) -> Eval.defsToEnv defs

preludeTyped :: Partial => TypeChecker.TypeEnv
preludeTyped = case buildTypeEnvironment preludeEnv of
  Just env -> env
  Nothing -> TypeChecker.emptyTypeEnv

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "data Maybe a = Nothing | Just a\n" <>
  "data List a = Nil | Cons a (List a)\n" <>
  "data IList a = INil | a :: (IList a)\n" <>
  "and (True:xs)  = and xs\n" <>
  "and (False:xs) = False\n" <>
  "and []         = True\n" <>
  "\n" <>
  "or (False:xs) = or xs\n" <>
  "or (True:xs)  = True\n" <>
  "or []         = False\n" <>
  "\n" <>
  "all p = and . map p\n" <>
  "any p = or . map p\n" <>
  "\n" <>
  "head (x:xs) = x\n" <>
  "tail (x:xs) = xs\n" <>
  "\n" <>
  "take 0 xs     = []\n" <>
  "take n (x:xs) = x : take (n - 1) xs\n" <>
  "\n" <>
  "drop 0 xs     = xs\n" <>
  "drop n (x:xs) = drop (n - 1) xs\n" <>
  "\n" <>
  "elem e []     = False\n" <>
  "elem e (x:xs) = if e == x then True else elem e xs\n" <>
  "\n" <>
  "max a b = if a >= b then a else b\n" <>
  "min a b = if b >= a then a else b\n" <>
  "\n" <>
  "maximum (x:xs) = foldr max x xs\n" <>
  "minimum (x:xs) = foldr min x xs\n" <>
  "\n" <>
  "length []     = 0\n" <>
  "length (x:xs) = 1 + length xs\n" <>
  "\n" <>
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" <>
  "zip []      _     = []\n" <>
  "zip _       []    = []\n" <>
  "\n" <>
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
  "zipWith _ []     _      = []\n" <>
  "zipWith _ _      []     = []\n" <>
  "\n" <>
  "unzip []          = ([], [])\n" <>
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" <>
  "\n" <>
  "fst (x,_) = x\n" <>
  "snd (_,x) = x\n" <>
  "\n" <>
  "curry f a b = f (a, b)\n" <>
  "uncurry f (a, b) = f a b\n" <>
  "\n" <>
  "repeat x = x : repeat x\n" <>
  "\n" <>
  "replicate 0 _ = []\n" <>
  "replicate n x = x : replicate (n - 1) x\n" <>
  "\n" <>
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" <>
  "\n" <>
  "sum (x:xs) = x + sum xs\n" <>
  "sum [] = 0\n" <>
  "\n" <>
  "product (x:xs) = x * product xs\n" <>
  "product [] = 1\n" <>
  "\n" <>
  "reverse []     = []\n" <>
  "reverse (x:xs) = reverse xs ++ [x]\n" <>
  "\n" <>
  "concat = foldr (++) []\n" <>
  "\n" <>
  "map f []     = []\n" <>
  "map f (x:xs) = f x : map f xs\n" <>
  "\n" <>
  "not True  = False\n" <>
  "not False = True\n" <>
  "\n" <>
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" <>
  "filter p []     = []\n" <>
  "\n" <>
  "foldr f ini []     = ini\n" <>
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" <>
  "\n" <>
  "foldl f acc []     = acc\n" <>
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" <>
  "\n" <>
  "scanl f b []     = [b]\n" <>
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" <>
  "\n" <>
  "iterate f x = x : iterate f (f x)\n" <>
  "\n" <>
  "id x = x\n" <>
  "\n" <>
  "const x _ = x\n" <>
  "\n" <>
  "flip f x y = f y x\n" <>
  "\n" <>
  "even n = (n `mod` 2) == 0\n" <>
  "odd n = (n `mod` 2) == 1\n" <>
  "\n" <>
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

-- main :: DOMEff J.JQuery
-- main = J.ready $ do
--   J.select "#input"
--     >>= J.on "change" (\_ _ -> startEvaluation)
--     >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else pure unit)
--   startEvaluation

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> pure unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

--   { env = env, out = out, history = histExprs } <- get :: EvalM EvalState
--   liftEff $ print out.expr
--   liftEff $ print out.typ

--   liftEff $ exprToJQuery out >>= wrapInDiv "output" >>= flip J.append output
--   showHistoryList histExprs >>= liftEff <<< flip J.append history

--   liftEff (J.find ".binary, .app, .func, .list, .if, .name" output)
--      >>= makeClickable
--   liftEff (J.find ".output div" output)
--     >>= addMouseOverListener
--     >>= addClickListener (out.typ)
--   liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

--   liftEff $ pure unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   pure scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

" >>= J.addClass "history"
--   tdExpr <- liftEff $ J.create "	"
--   liftEff $ exprToJQuery out >>= flip J.append tdExpr
--   liftEff $ J.append tdExpr row
--   es <- get :: EvalM EvalState
--   let deleteHandler = \_ _ -> do
--                         let es' = es { history = maybe es.history id (deleteAt i es.history) }
--                         void $ runStateT showEvaluationState es'
--   delete <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Delete"
--     >>= J.addClass "delete"
--     >>= J.on "click" deleteHandler
--   tdDelete <- liftEff $ J.create "	"
--   liftEff $ J.append delete tdDelete
--   liftEff $ J.append tdDelete row
--   let restoreHandler = \_ _ -> do
--                          let es' = es { history = drop (i + 1) es.history, out = maybe es.out id (es.history !! i) }
--                          void $ runStateT showEvaluationState es'
--   restore <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Restore"
--     >>= J.addClass "restore"
--     >>= J.on "click" restoreHandler
--   tdRestore <- liftEff $ J.create "	"
--   liftEff $ J.append restore tdRestore
--   liftEff $ J.append tdRestore row
--   pure row

-- showInfo :: String -> String -> DOMEff Unit
-- showInfo origin msg = do
--   info <- J.create "

"
--     >>= J.addClass "info"
--     >>= J.setText ("Error in " <> origin ++ " => " <> msg)
--   clearInfo
--   J.select "#info"
--     >>= J.append info
--   pure unit

-- clearInfo :: DOMEff Unit
-- clearInfo = void $ J.select "#info" >>= J.clear

-- prepareContainer :: String -> DOMEff J.JQuery
-- prepareContainer name = do
--   J.select ("#" <> name <> "-container") >>= J.clear

-- wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
-- wrapInDiv name jq = do
--   J.create "

" >>= J.addClass name >>= J.append jq

-- makeClickable :: J.JQuery -> EvalM Unit
-- makeClickable jq = do
--   { env = env, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then pure unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then pure unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> pure unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- addMouseOverListener :: J.JQuery -> EvalM J.JQuery
-- addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
--   where
--   handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler jEvent jq = do
--     J.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     pure unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree jq = do
--   evaluationState <- get
--   liftEff $ J.on "click" (handler evaluationState) jq
--   where
--   handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler evaluationState jEvent jq = do
--     J.stopImmediatePropagation jEvent
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path -> do
--         pure unit
--         if checkForError path typeTree
--           then pure unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

-- removeMouseOver :: DOMEff Unit
-- removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> pure unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

-- getValue :: J.JQuery -> DOMEff String
-- getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import AST as AST
import Parser as Parser
import Evaluator as Eval
import Web as Web
import TypeChecker as TypeChecker
import JSHelpers (ctrlKeyPressed, getType)

import Prelude
import DOM (DOM)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (empty)
import Data.Array (cons)
import Data.Traversable (for)
import Data.Tuple (Tuple (..))

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

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = log "hello"

makeCE :: forall eff. String -> String -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
makeCE input selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \expr -> do
    let env = preludeEnv
    showExprIn expr env [] container Nothing
    pure unit

makeCEwithDefs :: forall eff. String -> String -> String -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
makeCEwithDefs input defs selector = do
  clearInfo
  container <- J.select selector
  doWithJust (parseExpr input) \expr -> do
    let env = stringToEnv defs
    showExprIn expr env [] container Nothing

makeCEwithHistory :: forall eff. String -> String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
makeCEwithHistory input selector histSelector = do
  clearInfo
  container <- J.select selector
  histContainer <- J.select histSelector
  doWithJust (parseExpr input) \expr -> do
    let env = preludeEnv
    showExprIn expr env [] container (Just histContainer)

makeCEwithDefsAndHistory :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
makeCEwithDefsAndHistory  input defs selector histSelector = do
  clearInfo
  container <- J.select selector
  histContainer <- J.select histSelector
  doWithJust (parseExpr input) \expr -> do
    let env = stringToEnv defs
    showExprIn expr env [] container (Just histContainer)

-- | Try to parse the given expression and report parser errors.
parseExpr :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe AST.TypeTree)
parseExpr input = case Parser.parseExpr input of
  Left error -> do
    showError "Parser" (show error)
    pure Nothing
  Right (Tuple expr _)-> pure $ Just expr

eval1 :: Eval.Env -> AST.TypeTree -> Either String AST.TypeTree
eval1 env expr = case Eval.runEvalM (Eval.eval1 env expr) of
  Left err    -> Left $ show err
  Right expr' -> Right expr'

eval1' :: Eval.Env -> AST.TypeTree -> AST.TypeTree
eval1' env expr = case eval1 env expr of
  Left _      -> expr
  Right expr' -> expr'

makeCallback :: Eval.Env -> Array AST.TypeTree -> J.JQuery -> Maybe J.JQuery-> Web.Callback
makeCallback env history container histContainer expr hole event jq = do
  J.stopImmediatePropagation event
  let evalFunc = if ctrlKeyPressed event then Eval.eval else eval1'
  case getType event of
    "click"     -> if evalFunc env expr /= expr
                   then showExprIn (hole (evalFunc env expr)) env (cons (hole expr) history) container histContainer
                   else pure unit
    "mouseover" -> do
                     log $ show expr
                     case eval1 env expr of
                       Right expr' -> do
                         log $ show expr'
                         J.addClass "highlight" jq
                       Left err   -> log err
    "mouseout"  -> void $ J.removeClass "highlight" jq
    _           -> pure unit
  pure unit

exprToJQuery :: forall eff. Web.Callback -> AST.TypeTree -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
exprToJQuery callback = Web.exprToDiv >>> Web.divToJQuery true callback

-- | Clear the contents of info div.
clearInfo :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
clearInfo = void $ J.select "#info" >>= J.clear

-- | Create an info div and display an error inside.
showError :: forall eff. String -> String -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
showError origin msg = do
  info <- do
    paragraph <- J.create "

"
    J.addClass "info" paragraph
    J.setText ("Error in " <> origin <> " => " <> msg) paragraph
    pure paragraph
  clearInfo
  infoDiv <- J.select "#info"
  J.append info infoDiv

-- | Execute the given function if the given maybe (wrapped inside an effect) is a `Just x` value
-- | using `x` as the argument. If the maybe is `Nothing` don't do anything.
doWithJust :: forall a eff. Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe a)
         -> (a -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)
         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
doWithJust mMaybe f = do
  mValue <- mMaybe
  case mValue of
    Nothing -> pure unit
    Just x  -> f x

-- | Given an evaluation environment, try to infer the types inside of it.
buildTypeEnvironment :: Partial => Eval.Env -> Maybe TypeChecker.TypeEnv
buildTypeEnvironment env =
  let defs = Eval.envToDefs env
  in case TypeChecker.tryInferEnvironment defs of
    Left error -> Nothing
    Right typedEnv -> Just typedEnv

-- | Type check an expression using a given typed environment.
-- | Construct a div tree from the given typed expression.
typeCheckExpression :: forall eff. Partial => TypeChecker.TypeEnv -> AST.TypeTree
                 -> Eff (dom :: DOM, console :: CONSOLE | eff) (Maybe AST.TypeTree)
typeCheckExpression typedEnv expr = do
  case TypeChecker.runInferWith typedEnv false (TypeChecker.inferExpr expr) of
    Left typeError -> do
      showError "Expression" (AST.prettyPrintTypeError typeError)
      pure Nothing
    Right typedExpr -> do
      pure $ Just typedExpr

-- | Construct a div tree from the given typed expression.
buildDivTreeFromExpression :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree
                           -> J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
buildDivTreeFromExpression typedExpr env history container histContainer = do
    content <- exprToJQuery (makeCallback env history container histContainer) typedExpr
    J.clear container
    J.append content container
    case histContainer of
      Nothing -> pure unit
      Just histContainer -> do
        J.clear histContainer
        for history $ \typedExpr -> do
          histExpr <- exprToJQuery (\_ _ _ _ -> pure unit) typedExpr
          histDiv <- J.create "

"
          J.addClass "history-element" histDiv
          J.append histExpr histDiv
          J.append histDiv histContainer
        pure unit
    pure unit

-- | Show the given expression inside a given environment after the types of the environment as
-- | well as the expression have been inferred.
showExprIn :: forall eff. AST.TypeTree -> Eval.Env -> Array AST.TypeTree -> J.JQuery
           -> Maybe J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
showExprIn expr env history container histContainer = do
  -- Try to infer the types of the environment.
  -- doWithJust (buildTypeEnvironment expr env) \typedEnv -> do
    -- Try to infer the type of the given expression.
    -- doWithJust (typeCheckExpression preludeTyped expr) \typedExpr ->
      -- buildDivTreeFromExpression typedExpr env history container histContainer
    buildDivTreeFromExpression expr env history container histContainer

stringToEnv :: String -> Eval.Env
stringToEnv str = case Parser.parseDefs str of
  Left _     -> empty
  Right (Tuple defs _) -> Eval.defsToEnv defs

preludeTyped :: Partial => TypeChecker.TypeEnv
preludeTyped = case buildTypeEnvironment preludeEnv of
  Just env -> env
  Nothing -> TypeChecker.emptyTypeEnv

preludeEnv :: Eval.Env
preludeEnv = stringToEnv prelude

prelude :: String
prelude =
  "data Maybe a = Nothing | Just a\n" <>
  "data List a = Nil | Cons a (List a)\n" <>
  "data IList a = INil | a :: (IList a)\n" <>
  "and (True:xs)  = and xs\n" <>
  "and (False:xs) = False\n" <>
  "and []         = True\n" <>
  "\n" <>
  "or (False:xs) = or xs\n" <>
  "or (True:xs)  = True\n" <>
  "or []         = False\n" <>
  "\n" <>
  "all p = and . map p\n" <>
  "any p = or . map p\n" <>
  "\n" <>
  "head (x:xs) = x\n" <>
  "tail (x:xs) = xs\n" <>
  "\n" <>
  "take 0 xs     = []\n" <>
  "take n (x:xs) = x : take (n - 1) xs\n" <>
  "\n" <>
  "drop 0 xs     = xs\n" <>
  "drop n (x:xs) = drop (n - 1) xs\n" <>
  "\n" <>
  "elem e []     = False\n" <>
  "elem e (x:xs) = if e == x then True else elem e xs\n" <>
  "\n" <>
  "max a b = if a >= b then a else b\n" <>
  "min a b = if b >= a then a else b\n" <>
  "\n" <>
  "maximum (x:xs) = foldr max x xs\n" <>
  "minimum (x:xs) = foldr min x xs\n" <>
  "\n" <>
  "length []     = 0\n" <>
  "length (x:xs) = 1 + length xs\n" <>
  "\n" <>
  "zip (x:xs) (y:ys) = (x, y) : zip xs ys\n" <>
  "zip []      _     = []\n" <>
  "zip _       []    = []\n" <>
  "\n" <>
  "zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
  "zipWith _ []     _      = []\n" <>
  "zipWith _ _      []     = []\n" <>
  "\n" <>
  "unzip []          = ([], [])\n" <>
  "unzip ((a, b):xs) = (\\(as, bs) -> (a:as, b:bs)) $ unzip xs\n" <>
  "\n" <>
  "fst (x,_) = x\n" <>
  "snd (_,x) = x\n" <>
  "\n" <>
  "curry f a b = f (a, b)\n" <>
  "uncurry f (a, b) = f a b\n" <>
  "\n" <>
  "repeat x = x : repeat x\n" <>
  "\n" <>
  "replicate 0 _ = []\n" <>
  "replicate n x = x : replicate (n - 1) x\n" <>
  "\n" <>
  "enumFromTo a b = if a <= b then a : enumFromTo (a + 1) b else []\n" <>
  "\n" <>
  "sum (x:xs) = x + sum xs\n" <>
  "sum [] = 0\n" <>
  "\n" <>
  "product (x:xs) = x * product xs\n" <>
  "product [] = 1\n" <>
  "\n" <>
  "reverse []     = []\n" <>
  "reverse (x:xs) = reverse xs ++ [x]\n" <>
  "\n" <>
  "concat = foldr (++) []\n" <>
  "\n" <>
  "map f []     = []\n" <>
  "map f (x:xs) = f x : map f xs\n" <>
  "\n" <>
  "not True  = False\n" <>
  "not False = True\n" <>
  "\n" <>
  "filter p (x:xs) = if p x then x : filter p xs else filter p xs\n" <>
  "filter p []     = []\n" <>
  "\n" <>
  "foldr f ini []     = ini\n" <>
  "foldr f ini (x:xs) = f x (foldr f ini xs)\n" <>
  "\n" <>
  "foldl f acc []     = acc\n" <>
  "foldl f acc (x:xs) = foldl f (f acc x) xs\n" <>
  "\n" <>
  "scanl f b []     = [b]\n" <>
  "scanl f b (x:xs) = b : scanl f (f b x) xs\n" <>
  "\n" <>
  "iterate f x = x : iterate f (f x)\n" <>
  "\n" <>
  "id x = x\n" <>
  "\n" <>
  "const x _ = x\n" <>
  "\n" <>
  "flip f x y = f y x\n" <>
  "\n" <>
  "even n = (n `mod` 2) == 0\n" <>
  "odd n = (n `mod` 2) == 1\n" <>
  "\n" <>
  "fix f = f (fix f)\n"

-- import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
-- import Data.Foreign (unsafeFromForeign)
-- import Data.Foldable (any)
-- import Data.Either (Either(Right, Left), either)
-- import Data.Maybe (Maybe(Just, Nothing), maybe)
-- import Data.List (List(Nil), (:), singleton, (!!), drop, deleteAt, length, (..), zipWithA)

-- import Control.Monad.State.Trans (StateT, modify, get, runStateT)
-- import Control.Monad.Eff.Class (liftEff)

-- import Text.Parsing.Parser (ParseError(ParseError))
-- import Text.Parsing.Parser.Pos (Position(Position))
-- import Ace.Types (ACE())
-- import Ace.Editor as Editor
-- import Ace.EditSession as Session
-- import Ace.Range as  Range

-- import Web (exprToJQuery, getPath, idExpr, makeDiv)
-- import Evaluator (evalPath1, evalPathAll, Env(), defsToEnv, envToDefs, EvalError(..), MatchingError(..))
-- import AST (Path, Expr, TypeTree, Output, TypeError)
-- import TypeChecker (TypeEnv, txToABC, buildPartiallyTypedTree, typeTreeProgramnEnv, checkForError, prettyPrintTypeError, buildTypeEnv)
-- import Parser (parseDefs, parseExpr)
-- import JSHelpers (ctrlKeyPressed, prepend, jqMap, warnOnRefresh, isEnterKey, showTypes)

-- main :: DOMEff J.JQuery
-- main = J.ready $ do
--   J.select "#input"
--     >>= J.on "change" (\_ _ -> startEvaluation)
--     >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else pure unit)
--   startEvaluation

-- type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

-- type EvalState = { env :: Env, out :: Output, history :: List Output, typEnv :: TypeEnv }

-- type EvalM a = StateT EvalState DOMEff a

-- startEvaluation :: DOMEff Unit
-- startEvaluation = do
--   clearInfo
--   editor <- Ace.edit "definitions" Ace.ace
--   definitions <- Editor.getValue editor
--   input       <- J.select "#input"       >>= getValue

--   case parseExpr input of
--     Left err   -> showInfo "Expression" (show err)
--     Right expr -> do
--       case defsToEnv <$> parseDefs definitions of
--         Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
--           showInfo "Definitions" (show err)
--           markText (line - 1) column
--         Right env -> case buildTypeEnv (envToDefs env) of --  type Env
--           Left err -> showInfo "Definitions" (prettyPrintTypeError err)
--           Right typEnv -> do
--             let showEvalState typ' = let typ = txToABC typ' in
--               let idTree = idExpr expr in
--               void $ runStateT showEvaluationState { env: env, out: {expr:expr, typ:typ, idTree:idTree}, history: Nil, typEnv:typEnv }
--             case typeTreeProgramnEnv typEnv expr of
--               Left err -> do
--                 showTypes
--                 let typ' = buildPartiallyTypedTree typEnv expr
--                 showEvalState typ'
--               Right typ' -> showEvalState typ'

-- outIfErr::forall b. String -> Either TypeError b -> DOMEff Unit
-- outIfErr origin either = case either of
--   Left err -> showInfo origin (prettyPrintTypeError err)
--   Right _ -> pure unit

-- markText :: Int -> Int -> DOMEff Unit
-- markText line column = do
--   editor <- Ace.edit "definitions" Ace.ace
--   session <- Editor.getSession editor
--   rang <- Range.create line column 100000 100000
--   void $ Session.addMarker rang "syntaxError" "" false session

-- showEvaluationState :: EvalM Unit
-- showEvaluationState = do
--   liftEff $ warnOnRefresh
--   output <- liftEff $ prepareContainer "output"
--   history <- liftEff $ prepareContainer "history"
--   typContainer <- liftEff $ prepareContainer "typ"
--   svgContainer <- liftEff $ prepareContainer "svg"

--   { env = env, out = out, history = histExprs } <- get :: EvalM EvalState
--   liftEff $ print out.expr
--   liftEff $ print out.typ

--   liftEff $ exprToJQuery out >>= wrapInDiv "output" >>= flip J.append output
--   showHistoryList histExprs >>= liftEff <<< flip J.append history

--   liftEff (J.find ".binary, .app, .func, .list, .if, .name" output)
--      >>= makeClickable
--   liftEff (J.find ".output div" output)
--     >>= addMouseOverListener
--     >>= addClickListener (out.typ)
--   liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

--   liftEff $ pure unit :: DOMEff Unit

-- forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
-- forIndex as f = zipWithA f as (0 .. (length as - 1))

-- showHistoryList :: (List Output) -> EvalM J.JQuery
-- showHistoryList exprs = do
--   box <- liftEff $ J.create "

" >>= J.addClass "historyBox" >>= J.addClass "vertical" >>= J.addClass "frame"
--   forIndex exprs $ \expr i -> do
--     showHistoryRow expr i >>= liftEff <<< flip J.append box
--   scroll <- liftEff $ J.create "

" >>= J.addClass "scroll"
--   liftEff $ J.append box scroll
--   pure scroll

-- showHistoryRow :: Output -> Int -> EvalM J.JQuery
-- showHistoryRow out i = do
--   row <- liftEff $ J.create "

" >>= J.addClass "history"
--   tdExpr <- liftEff $ J.create "	"
--   liftEff $ exprToJQuery out >>= flip J.append tdExpr
--   liftEff $ J.append tdExpr row
--   es <- get :: EvalM EvalState
--   let deleteHandler = \_ _ -> do
--                         let es' = es { history = maybe es.history id (deleteAt i es.history) }
--                         void $ runStateT showEvaluationState es'
--   delete <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Delete"
--     >>= J.addClass "delete"
--     >>= J.on "click" deleteHandler
--   tdDelete <- liftEff $ J.create "	"
--   liftEff $ J.append delete tdDelete
--   liftEff $ J.append tdDelete row
--   let restoreHandler = \_ _ -> do
--                          let es' = es { history = drop (i + 1) es.history, out = maybe es.out id (es.history !! i) }
--                          void $ runStateT showEvaluationState es'
--   restore <- liftEff $ J.create "<button></button>"
--     >>= J.setText "Restore"
--     >>= J.addClass "restore"
--     >>= J.on "click" restoreHandler
--   tdRestore <- liftEff $ J.create "	"
--   liftEff $ J.append restore tdRestore
--   liftEff $ J.append tdRestore row
--   pure row

-- showInfo :: String -> String -> DOMEff Unit
-- showInfo origin msg = do
--   info <- J.create "

"
--     >>= J.addClass "info"
--     >>= J.setText ("Error in " <> origin ++ " => " <> msg)
--   clearInfo
--   J.select "#info"
--     >>= J.append info
--   pure unit

-- clearInfo :: DOMEff Unit
-- clearInfo = void $ J.select "#info" >>= J.clear

-- prepareContainer :: String -> DOMEff J.JQuery
-- prepareContainer name = do
--   J.select ("#" <> name <> "-container") >>= J.clear

-- wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
-- wrapInDiv name jq = do
--   J.create "

" >>= J.addClass name >>= J.append jq

-- makeClickable :: J.JQuery -> EvalM Unit
-- makeClickable jq = do
--   { env = env, out = out } <- get
--   let expr = out.expr
--   let typeTree = out.typ
--   liftEff $ jqMap (testEval env expr typeTree) jq
--   where
--   testEval :: Env -> Expr -> TypeTree -> J.JQuery -> DOMEff Unit
--   testEval env expr typeTree jq = do
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path ->
--         case evalPath1 env path expr of
--           Left err -> displayEvalError err jq
--           Right _  -> if checkForError path typeTree
--             then pure unit
--             else void $ J.addClass "clickable" jq

-- displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
-- displayEvalError err jq = case err of
--   DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip prepend jq
--   NoMatchingFunction _ errs -> if (any missesArguments errs)
--     then pure unit
--     else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip prepend jq
--   _         -> pure unit
--   where
--     missesArguments (TooFewArguments _ _) = true
--     missesArguments (StrictnessError _ _) = true
--     missesArguments _                     = false

-- addMouseOverListener :: J.JQuery -> EvalM J.JQuery
-- addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
--   where
--   handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler jEvent jq = do
--     J.stopPropagation jEvent
--     removeMouseOver
--     J.addClass "mouseOver" jq
--     pure unit

-- addClickListener :: TypeTree ->  J.JQuery -> EvalM J.JQuery
-- addClickListener typeTree jq = do
--   evaluationState <- get
--   liftEff $ J.on "click" (handler evaluationState) jq
--   where
--   handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
--   handler evaluationState jEvent jq = do
--     J.stopImmediatePropagation jEvent
--     mpath <- getPath jq
--     case mpath of
--       Nothing   -> pure unit
--       Just path -> do
--         pure unit
--         if checkForError path typeTree
--           then pure unit
--           else case ctrlKeyPressed jEvent of
--                 false -> void $ runStateT (evalExpr evalPath1 path) evaluationState
--                 true  -> void $ runStateT (evalExpr evalPathAll path) evaluationState

-- removeMouseOver :: DOMEff Unit
-- removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

-- evalExpr :: (Env -> Path -> Expr -> Either EvalError Expr) -> Path -> EvalM Unit
-- evalExpr eval path = do
--   { env = env, out = out, typEnv = typEnv} <- get
--   let expr = out.expr
--   liftEff $ print path
--   case eval env path expr of
--     Left msg    -> pure unit
--     Right expr' -> do
--         let eitherTyp = typeTreeProgramnEnv typEnv expr'
--         let typ'' = either (\_ -> buildPartiallyTypedTree typEnv expr') id eitherTyp
--         let typ' = txToABC typ''
--         modify (\es -> es { out = {expr:expr', typ:typ', idTree:idExpr expr'} })
--         modify (\es -> es { history = out : es.history })
--         showEvaluationState

-- getValue :: J.JQuery -> DOMEff String
-- getValue jq = unsafeFromForeign <$> J.getValue jq


formatted

formatted

module Blueprint.Components.Button where

import Blueprint.ComponentsClasses (anchorButtonClass, buttonClass)
import Blueprint.PropTypes (ActionPropsEx, Prop, UnknownRefType)
import React

type ButtonProps =  ButtonPropsEx ()

-- DISCUSS: Do we need this to be extensible?
type ButtonPropsEx r = ActionPropsEx
  ( elementRef :: UnknownRefType
  , rightIconName :: String
  , loading :: Boolean
  , type :: String -- TODO: lets avoid using keywords in field names.
  | r
  )

anchorButton :: Prop ButtonProps -> Array ReactElement -> ReactElement
anchorButton = createElement anchorButtonClass

button :: Prop ButtonProps -> Array ReactElement -> ReactElement
button = createElement buttonClass

module Blueprint.Components.Button where

import React
import Blueprint.PropTypes (IActionPropsEx, Prop, UnknownRefType)
import Blueprint.ComponentsClasses (anchorButtonClass, buttonClass)

type ButtonProps =  ButtonPropsEx ()
type ButtonPropsEx r =  IActionPropsEx ( elementRef :: UnknownRefType
                                       , rightIconName :: String
                                       , loading :: Boolean
                                       , type :: String
                                       | r
                                       )

button :: Prop ButtonProps -> Array ReactElement -> ReactElement
button = createElement buttonClass

anchorButton :: Prop ButtonProps -> Array ReactElement -> ReactElement
anchorButton = createElement anchorButtonClass


Make contracts more type safe

Make contracts more type safe

module Lib.SignHash.Contracts where

import Prelude

import Control.Monad.Aff (Aff, attempt, error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, toAffE)
import Data.Array (head)
import Data.Either (Either(..))
import Data.Foreign (toForeign)
import Data.Foreign.Index ((!))
import Data.Maybe (maybe)
import FFI.Util (property)
import FFI.Util.Function (call1, callEff2)
import Lib.SignHash.Types (Checksum, HashSigner(..))
import Lib.Web3 (Bytes(..), WEB3, Web3)

type Address = String

newtype ContractData t = ContractData t

class Contract c

newtype Result e = Result e

address :: forall c. Contract c => c -> Address
address = prop "address"

prop :: forall a b. String -> a -> b
prop = flip property

getResult :: forall a. Result a -> a
getResult = prop "result"

checksumToBytes :: String -> Bytes
checksumToBytes = Bytes <<< append "0x"

getDeployed ::
  forall eff t.
  ContractData t ->
  Web3 ->
  Aff (web3 :: WEB3 | eff) (Either Error t)
getDeployed contractData web3 = do
  networkId <- toAffE (web3 `property` "net_version")

  let address =
        runExcept $
        (toForeign contractData) ! "networks" ! networkId ! "address"

  pure case address of
    Left err -> Left $ error $ "Contract is not deployed to network id:"
                <> networkId
    Right value -> do
      let contract = call1 web3 "contract" (contractData `property` "abi")
      Right $ call1 contract "at" value

foreign import data SignerContract :: Type
instance _signerContract :: Contract SignerContract

foreign import signerContractData :: ContractData SignerContract

signerContract ::
  forall eff. Web3 -> Aff (web3 :: WEB3 | eff) (Either Error SignerContract)
signerContract = getDeployed signerContractData

foreign import _sign ::
  forall eff.
  SignerContract ->
  Bytes ->
  Address ->
  Eff (web3 :: WEB3 | eff) (Promise Unit)

sign ::
  forall eff.
  SignerContract ->
  Checksum ->
  Address ->
  Aff (web3 :: WEB3 | eff) (Either Error Unit)
sign contract checksum signer =
  attempt $ toAffE $ _sign contract (checksumToBytes checksum) signer

rawGetSigners ::
  forall eff.
  SignerContract ->
  Bytes ->
  Int ->
  Aff (web3 :: WEB3 | eff) (Result (Array String))
rawGetSigners contract bytes size =
  toAffE $ callEff2 contract "getSigners" bytes size

getSigners ::
  forall eff.
  SignerContract ->
  Checksum ->
  Int ->
  Aff (web3 :: WEB3 | eff) (Array String)
getSigners contract checksum size =
  getResult <$> rawGetSigners contract (checksumToBytes checksum) size

getSigner ::
  forall eff. SignerContract -> Checksum -> Aff (web3 :: WEB3 | eff) HashSigner
getSigner contract checksum = do
  signers <- getSigners contract checksum 1
  pure $ maybe NoSigner HashSigner $ head signers

module Lib.SignHash.Contracts where

import Prelude

import Control.Monad.Aff (Aff, attempt, error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, toAffE)
import Data.Array (head)
import Data.Either (Either(..))
import Data.Foreign (toForeign)
import Data.Foreign.Index ((!))
import Data.Maybe (maybe)
import Debug.Trace (spy, traceA, traceAnyM)
import FFI.Util (property)
import FFI.Util.Function (call1, callEff2)
import Lib.SignHash.Types (Checksum, HashSigner(..))
import Lib.Web3 (WEB3, Web3, bytesFromASCII)

type Address = String

newtype ContractData t = ContractData t

class Contract c

address :: forall c. Contract c => c -> Address
address = prop "address"

prop :: forall a b. String -> a -> b
prop = flip property

getDeployed ::
  forall eff t.
  ContractData t ->
  Web3 ->
  Aff (web3 :: WEB3 | eff) (Either Error t)
getDeployed contractData web3 = do
  networkId <- toAffE (web3 `property` "net_version")

  let address =
        runExcept $
        (toForeign contractData) ! "networks" ! networkId ! "address"

  pure case address of
    Left err -> Left $ error $ "Contract is not deployed to network id:"
                <> networkId
    Right value -> do
      let contract = call1 web3 "contract" (contractData `property` "abi")
      Right $ call1 contract "at" value

foreign import data SignerContract :: Type
instance _signerContract :: Contract SignerContract

foreign import signerContractData :: ContractData SignerContract

signerContract ::
  forall eff. Web3 -> Aff (web3 :: WEB3 | eff) (Either Error SignerContract)
signerContract = getDeployed signerContractData

foreign import _sign ::
  forall eff.
  SignerContract ->
  Checksum ->
  Address ->
  Eff (web3 :: WEB3 | eff) (Promise Unit)

sign ::
  forall eff.
  SignerContract ->
  Checksum ->
  Address ->
  Aff (web3 :: WEB3 | eff) (Either Error Unit)
sign contract checksum signer =
  attempt $ toAffE $ _sign contract ("0x" <> checksum) signer

getSigners ::
  forall eff.
  SignerContract ->
  Checksum ->
  Int ->
  Aff (web3 :: WEB3 | eff) (Array String)
getSigners contract checksum size = do
  value <- toAffE $ callEff2 contract "getSigners" ("0x" <> checksum) size
  pure $ getResult value

getSigner ::
  forall eff. SignerContract -> Checksum -> Aff (web3 :: WEB3 | eff) HashSigner
getSigner contract checksum = do
  signers <- getSigners contract checksum 1
  pure $ maybe NoSigner HashSigner $ head signers

getResult :: forall a b. a -> b
getResult = prop "0"


Fix some types

Fix some types

module JQuery where

  import Data.JSON
  import Control.Monad.Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import setAttr
    "function setAttr(attr) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.attr(attr, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import setProp
    "function setProp(p) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.prop(p, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import getProp
    "function getProp(p) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.prop(p);\
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JSON

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  foreign import appendAtIndex
    "function appendAtIndex(i) { \
    \  return function(ob1) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob1.before(ob.children()[i]); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .remove()
  foreign import remove
    "function remove(ob) { \
    \  return function () { \
    \    return ob.remove(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .before(...)
  foreign import before
    "function before(ob) { \
    \  return function(ob1) { \
    \    return function () { \
    \      return ob1.before(ob); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JSON

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery

module JQuery where

  import Data.JSON
  import Control.Monad.Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import setAttr
    "function setAttr(attr) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.attr(attr, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff attr. String -> JSON -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import setProp
    "function setProp(p) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.prop(p, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff attr. String -> JSON -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import getProp
    "function getProp(p) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.prop(p);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. String -> JQuery -> Eff (dom :: DOM | eff) JSON

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  foreign import appendAtIndex
    "function appendAtIndex(i) { \
    \  return function(ob1) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob1.before(ob.children()[i]); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .remove()
  foreign import remove
    "function remove(ob) { \
    \  return function () { \
    \    return ob.remove(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .before(...)
  foreign import before
    "function before(ob) { \
    \  return function(ob1) { \
    \    return function () { \
    \      return ob1.before(ob); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JSON

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff. JSON -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery


Fix Ord instance

Fix Ord instance

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Prelude
import Data.Enum
import Data.Maybe
import Control.Monad.Eff

unsafeFromJust :: forall a. Maybe a -> a
unsafeFromJust (Just a) = a

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Prelude.Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Prelude.Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Data.Enum.Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Prelude.Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Data.Enum.Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Prelude.Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import now
  "function now() { \
  \  return DateTime(new Date()); \
  \}" :: forall e. Eff (now :: Now | e) Date

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Prelude.Show Date where
  show = liftDate $ jsDateMethod "toString"

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Prelude
import Data.Enum
import Data.Maybe
import Control.Monad.Eff

unsafeFromJust :: forall a. Maybe a -> a
unsafeFromJust (Just a) = a

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Prelude.Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Prelude.Ord Date where
  (<) = liftOp (<)
  (<=) = liftOp (<=)
  (>) = liftOp (>)
  (>=) =  liftOp (>=)

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Data.Enum.Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Prelude.Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Data.Enum.Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Prelude.Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import now
  "function now() { \
  \  return DateTime(new Date()); \
  \}" :: forall e. Eff (now :: Now | e) Date

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Prelude.Show Date where
  show = liftDate $ jsDateMethod "toString"


Fix ace example

Fix ace example

module Example.Ace.AceComponent where

import Prelude

import Ace as Ace
import Ace.EditSession as Session
import Ace.Editor as Editor
import Ace.Types (Editor)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

type Slot = H.Slot Query Output

data Query a = ChangeText String a

data Output = TextChanged String

data Action
  = Initialize
  | Finalize
  | HandleChange

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type State = { editor :: Maybe Editor }

-- | The Ace component definition.
component :: forall i m. MonadAff m => H.Component HH.HTML Query i Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval
        { handleAction = handleAction
        , handleQuery = handleQuery
        , initialize = Just Initialize
        , finalize = Just Finalize
        }
    }

initialState :: forall i. i -> State
initialState _ = { editor: Nothing }

-- As we're embedding a 3rd party component we only need to create a placeholder
-- div here and attach the ref property which will let us reference the element
-- in eval.
render :: forall m. State -> H.ComponentHTML Action () m
render = const $ HH.div [ HP.ref (H.RefLabel "ace") ] []

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  Initialize -> do
    H.getHTMLElementRef (H.RefLabel "ace") >>= traverse_ \element -> do
      editor <- H.liftEffect $ Ace.editNode element Ace.ace
      session <- H.liftEffect $ Editor.getSession editor
      H.modify_ (_ { editor = Just editor })
      void $ H.subscribe $ ES.effectEventSource \emitter -> do
        Session.onChange session (\_ -> ES.emit emitter HandleChange)
        pure mempty
  Finalize -> do
    -- Release the reference to the editor and do any other cleanup that a
    -- real world component might need.
    H.modify_ (_ { editor = Nothing })
  HandleChange -> do
    H.gets _.editor >>= traverse_ \editor -> do
      text <- H.liftEffect (Editor.getValue editor)
      H.raise $ TextChanged text

handleQuery :: forall m a. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
  ChangeText text next -> do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        current <- H.liftEffect $ Editor.getValue editor
        when (text /= current) do
          void $ H.liftEffect $ Editor.setValue text Nothing editor
    H.raise $ TextChanged text
    pure (Just next)

module Example.Ace.AceComponent where

import Prelude

import Ace as Ace
import Ace.EditSession as Session
import Ace.Editor as Editor
import Ace.Types (Editor)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

type Slot = H.Slot Query Output

data Query a = ChangeText String a

data Output = TextChanged String

data Action
  = Initialize
  | Finalize
  | HandleChange

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type State = { editor :: Maybe Editor }

-- | The Ace component definition.
component :: forall i m. MonadAff m => H.Component HH.HTML Query i Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval
        { handleAction = handleAction
        , handleQuery = handleQuery
        , initialize = Just Initialize
        , finalize = Just Finalize
        }
    }

initialState :: forall i. i -> State
initialState _ = { editor: Nothing }

-- As we're embedding a 3rd party component we only need to create a placeholder
-- div here and attach the ref property which will let us reference the element
-- in eval.
render :: forall m. State -> H.ComponentHTML Action () m
render = const $ HH.div [ HP.ref (H.RefLabel "ace") ] []

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  Initialize -> do
    H.getHTMLElementRef (H.RefLabel "ace") >>= traverse_ \element -> do
      editor <- H.liftEffect $ Ace.editNode element Ace.ace
      session <- H.liftEffect $ Editor.getSession editor
      H.modify_ (_ { editor = Just editor })
      void $ H.subscribe $ ES.effectEventSource \emitter -> do
        Session.onChange session (ES.emit emitter HandleChange)
        pure mempty
  Finalize -> do
    -- Release the reference to the editor and do any other cleanup that a
    -- real world component might need.
    H.modify_ (_ { editor = Nothing })
  HandleChange -> do
    H.gets _.editor >>= traverse_ \editor -> do
      text <- H.liftEffect (Editor.getValue editor)
      H.raise $ TextChanged text

handleQuery :: forall m a. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
  ChangeText text next -> do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        current <- H.liftEffect $ Editor.getValue editor
        when (text /= current) do
          void $ H.liftEffect $ Editor.setValue text Nothing editor
    H.raise $ TextChanged text
    pure (Just next)


Only users with the role admin_user have admin access.

This closes #23.

module Components.Admin where

import Components.SpeakerQueue as SQ
import Control.Monad.Aff (Aff)
import Data.Either (Either(..), either, note)
import Data.HTTP.Method (Method(..))
import Data.List as L
import Data.Maybe (Maybe(Nothing, Just))
import Effects (LemmingPantsEffects)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.StatusCode (StatusCode(..))
import Postgrest (createURL)
import Postgrest as PG
import Prelude (type (~>), Unit, bind, const, id, map, pure, show, unit, (*>), (<>), (==), (>>=))
import Types.Agenda (Agenda, AgendaItem(..))
import Types.Agenda as AG
import Types.Attendee (AttendeeDB)
import Types.Token (Payload(..), Token(..))

type State =
  { agenda    :: Agenda
  , token     :: Token
  , attendees :: AttendeeDB
  }
type Input = State

data Query a
  = PreviousAI       a
  | NextAI           a
  | SQMsg SQ.Message a
  | GotNewState State a

data Message
  = Flash String

component :: forall e. H.Component HH.HTML Query Input Message (Aff (LemmingPantsEffects e))
component =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: HE.input GotNewState
    }
  where
    render :: State -> H.ParentHTML Query SQ.Query Unit (Aff (LemmingPantsEffects e))
    render state =
      if pl.role == "admin_user"
        then
          HH.div_
            ([ HH.h1_ [HH.text "The Secret Supreme Council Interface"]
            , HH.h2_
              [ HH.button
                [ HE.onClick (HE.input_ PreviousAI) ]
                [ HH.text "⇐" ]
              , HH.text " "
              , HH.text (either id id (map (\(AgendaItem a) -> a.title) currentAI))
              , HH.text " "
              , HH.button
                [ HE.onClick (HE.input_ NextAI) ]
                [ HH.text "⇒" ]
              ]
            ] <> either
                (const [HH.text "No agenda item => no speaker queue."])
                (\ai@(AgendaItem ai') ->
                  let sqHeight = L.length ai'.speakerQueues in
                  [ HH.p_ [ HH.text ("Speaker queue stack height: " <> show sqHeight) ]
                  , case AG.topSQ ai of
                      Nothing -> HH.text "We have no speaker queues I'm afraid. This shouldn't happen. It happened anyway."
                      Just sq ->
                        HH.slot
                          unit
                          SQ.component
                          { speakerQueue: sq, token: state.token, attendees: state.attendees, agendaItemId: ai'.id, sqHeight }
                          (HE.input SQMsg)
                  ])
                currentAI
            )
        else
          HH.div_
            [ HH.p_
              [ HH.text "Please "
              , HH.a
                  [ HP.href "#login" ]
                  [ HH.text "login"  ]
              , HH.text " to access the admin interface."
              ]
            ]
      where
        currentAI    = AG.getCurrentAI state.agenda
        (Payload pl) = let (Token t) = state.token in t.payload

    eval :: Query ~> H.ParentDSL State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e))
    eval =
      case _ of
        PreviousAI next ->
           step AG.prev *> pure next
        NextAI next ->
          step AG.next *> pure next
        SQMsg (SQ.Flash m) next ->
          H.raise (Flash m) *> pure next
        GotNewState s next ->
          H.put s *> pure next

    step
      :: (Agenda -> Maybe Agenda)
      -> H.HalogenM State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e)) Unit
    step f =
      H.get
        >>= \s ->
            setCurrentAgendaItem ((note "ERROR: Agenda: Out of bounds step." (f s.agenda)) >>= AG.getCurrentAI)

    setCurrentAgendaItem
      :: Either String AgendaItem
      -> H.HalogenM State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e)) Unit
    setCurrentAgendaItem mai =
      case mai of
        Left s ->
          H.raise (Flash s)
        Right (AgendaItem c) -> do
          s <- H.get
          r <- H.liftAff (PG.emptyResponse
                 (createURL "/rpc/set_current_agenda_item")
                 s.token
                 POST
                 {id: c.id})
          case r.status of
            StatusCode 200 ->
              pure unit
            _ ->
              H.raise (Flash "setCurrentAgendaItem -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")

module Components.Admin where

import Components.SpeakerQueue as SQ
import Control.Monad.Aff (Aff)
import Data.Either (Either(..), either, note)
import Data.HTTP.Method (Method(..))
import Data.List as L
import Data.Maybe (Maybe(Nothing, Just))
import Effects (LemmingPantsEffects)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Network.HTTP.StatusCode (StatusCode(..))
import Postgrest (createURL)
import Postgrest as PG
import Prelude (type (~>), Unit, bind, const, id, map, pure, show, unit, (*>), (<>), (>>=))
import Types.Agenda (Agenda, AgendaItem(..))
import Types.Agenda as AG
import Types.Attendee (AttendeeDB)
import Types.Token (Token)

type State =
  { agenda    :: Agenda
  , token     :: Token
  , attendees :: AttendeeDB
  }
type Input = State

data Query a
  = PreviousAI       a
  | NextAI           a
  | SQMsg SQ.Message a
  | GotNewState State a

data Message
  = Flash String

component :: forall e. H.Component HH.HTML Query Input Message (Aff (LemmingPantsEffects e))
component =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: HE.input GotNewState
    }
  where
    render :: State -> H.ParentHTML Query SQ.Query Unit (Aff (LemmingPantsEffects e))
    render state =
      HH.div_
        ([ HH.h1_ [HH.text "Supreme council interface"]
        , HH.h2_
          [ HH.button
            [ HE.onClick (HE.input_ PreviousAI) ]
            [ HH.text "⇐" ]
          , HH.text " "
          , HH.text (either id id (map (\(AgendaItem a) -> a.title) currentAI))
          , HH.text " "
          , HH.button
            [ HE.onClick (HE.input_ NextAI) ]
            [ HH.text "⇒" ]
          ]
        ] <> either
            (const [HH.text "No agenda item => no speaker queue."])
            (\ai@(AgendaItem ai') ->
              let sqHeight = L.length ai'.speakerQueues in
              [ HH.p_ [ HH.text ("Speaker queue stack height: " <> show sqHeight) ]
              , case AG.topSQ ai of
                  Nothing -> HH.text "We have no speaker queues I'm afraid. This shouldn't happen. It happened anyway."
                  Just sq ->
                    HH.slot
                      unit
                      SQ.component
                      { speakerQueue: sq, token: state.token, attendees: state.attendees, agendaItemId: ai'.id, sqHeight }
                      (HE.input SQMsg)
              ])
            currentAI
        )
      where
        currentAI = AG.getCurrentAI state.agenda

    eval :: Query ~> H.ParentDSL State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e))
    eval =
      case _ of
        PreviousAI next ->
           step AG.prev *> pure next
        NextAI next ->
          step AG.next *> pure next
        SQMsg (SQ.Flash m) next ->
          H.raise (Flash m) *> pure next
        GotNewState s next ->
          H.put s *> pure next

    step
      :: (Agenda -> Maybe Agenda)
      -> H.HalogenM State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e)) Unit
    step f =
      H.get
        >>= \s ->
            setCurrentAgendaItem ((note "ERROR: Agenda: Out of bounds step." (f s.agenda)) >>= AG.getCurrentAI)

    setCurrentAgendaItem
      :: Either String AgendaItem
      -> H.HalogenM State Query SQ.Query Unit Message (Aff (LemmingPantsEffects e)) Unit
    setCurrentAgendaItem mai =
      case mai of
        Left s ->
          H.raise (Flash s)
        Right (AgendaItem c) -> do
          s <- H.get
          r <- H.liftAff (PG.emptyResponse
                 (createURL "/rpc/set_current_agenda_item")
                 s.token
                 POST
                 {id: c.id})
          case r.status of
            StatusCode 200 ->
              pure unit
            _ ->
              H.raise (Flash "setCurrentAgendaItem -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")