Comply with the updated purescript-jquery API

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

import Prelude (class Show, class Monad, Unit, (+), bind, ($), (==), (/=), show, (<>), (>>=), flip, pure, (<<<), (<$>), (&&), (>), void, unit, id, (-))
import Data.Foldable (all)
import Data.Traversable (for, for_)
import Data.String (joinWith)
import Data.List (List(Nil, Cons), singleton, fromFoldable, toUnfoldable, length, zip, (..), zipWithA)
import Data.Foreign (unsafeFromForeign, isUndefined)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Array as Array

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
--import Control.Monad (when)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import Control.Monad.State (State, put, get, runState)
import DOM (DOM)

import AST (Atom(..), Binding(..), Expr(..), Qual(..), ExprQual, TypeQual, IndexQual, QualTree(..), Op(), pPrintOp, Output(),Type(..), IndexTree(..),IBinding(..),TypeTree(..),TypeBinding(..), Path(..), extractType)
import TypeChecker (prettyPrintType, mapM)
import JSHelpers (showTooltip, children)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) (Maybe Path)
getPath j = do
  fpath <- J.getProp pathPropName j
  if isUndefined fpath
    then pure Nothing
    else pure $ Just $ unsafeFromForeign fpath

exprToJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go (output.expr)
  where
    go (Atom (Name _)) = exprToJQuery' output
    go (Atom _) = topLevel
    go (Binary _ _ _) = exprToJQuery' output
    go (PrefixOp _) = topLevel
    go _ = exprToJQuery' output

    topLevel = case extractType output.typ of
        TypeError _ -> exprToJQuery' output
        _ -> do
          jtypExp <- makeDiv "" (singleton "top typExpContainer")
          jExpand <- buildExpandDiv (extractType output.typ)
          J.append jExpand jtypExp
          jExpr <- exprToJQuery' output
          J.addClass "expr" jExpr
          J.append jExpr jtypExp
          pure jtypExp

-- TODO rename to fit new Type
exprToJQuery' :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery' output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o =
    (\jObj -> do
          let f = J.setProp pathPropName (p End)
          jExpr <- children ".expr" jObj
          isNotEmpty <- J.hasClass "expr" jExpr
          if isNotEmpty then f jExpr else f jObj
          pure jObj
          )
    =<<
    case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2
    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case toStr es of
                  Just str  -> string str t i
                  Nothing -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                                list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" <> pPrintOp op <> ")") (Array.toUnfoldable ["prefix", "op"]) >>= addTypetoDiv t >>= addIdtoDiv i
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i

    {expr:(ArithmSeq start step end), typ:(TArithmSeq tstart tstep tend t), idTree:(IArithmSeq istart istep iend i)} -> do
      jStart <- go (p <<< Fst)  {expr:start, typ:tstart, idTree:istart}
      case (isJust step) && (isJust tstep) && (isJust istep) of
        true  -> case (isJust end) && (isJust tend) && (isJust iend) of
          true  -> do
            jStep <- go (p <<< Snd) {expr:(fromJust step), typ:(fromJust tstep), idTree:(fromJust istep)}
            jEnd  <- go (p <<< Thrd) {expr:(fromJust end), typ:(fromJust tend), idTree:(fromJust iend)}
            arithmeticSequence jStart (Just jStep) (Just jEnd) t i
          false -> do
            jStep <- go (p <<< Snd) {expr:(fromJust step), typ:(fromJust tstep), idTree:(fromJust istep)}
            arithmeticSequence jStart (Just jStep) Nothing t i
        false -> case (isJust end) && (isJust tend) && (isJust iend) of
          true  -> do
            jEnd  <- go (p <<< Thrd) {expr:(fromJust end), typ:(fromJust tend), idTree:(fromJust iend)}
            arithmeticSequence jStart Nothing (Just jEnd) t i
          false -> do
            arithmeticSequence jStart Nothing Nothing t i

    {expr:(ListComp expr quals), typ:(TListComp texpr tquals t), idTree:(IListComp iexpr iquals i)} -> do
      jExpr  <- go (p <<< Fst) {expr:expr, typ:texpr, idTree:iexpr}
      jQuals <- zipWithA (\i (Tuple i' (Tuple e t)) -> qualifier (p <<< Nth i) e t i')
        (0 .. (length quals - 1)) (zip iquals (zip quals tquals))
      listComp jExpr jQuals t i

    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs (extractType tt) t i
    {expr: Unary op exp, typ: TUnary opt tt t, idTree:IUnary opi is i} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      jexpr <- go (p <<< Fst) {expr: exp, typ: tt, idTree: is}
      unary jop jexpr t i

    {expr: LetExpr binds exp, typ: TLetExpr tbinds texp t, idTree: ILetExpr ibinds iexp i} -> case checkLength binds tbinds ibinds of
      false -> makeDiv "oops! LetExpr bindings length error!" Nil
      true  -> do
        let fstBoundle = zip (fst <$> ibinds) (zip (fst <$> binds) (fst <$> tbinds))
            sndBoundle = zip (snd <$> ibinds) (zip (snd <$> binds) (snd <$> tbinds))

        jbinds <- mapM binding fstBoundle
        jexprs <- zipWithA (\x (Tuple i (Tuple b t)) -> go (p <<< Nth x) {expr: b, typ: t, idTree: i}) (1 .. (length sndBoundle)) sndBoundle
        jletBinds <- zipWithA letBinding jbinds jexprs

        jexpr <- go (p <<< Fst) {expr: exp, typ: texp, idTree: iexp}
        letExpr jletBinds jexpr t i

    {} -> makeDiv "You found a Bug" Nil

  qualifier :: (Path -> Path) -> ExprQual -> TypeQual -> IndexQual -> Eff (dom :: DOM | eff) J.JQuery
  qualifier p (Gen b e) (TGen tb te t) (TGen ib ie i) = do
      result <- makeDiv "" Nil
      addTypetoDiv t result
      addIdtoDiv i result
      binding (Tuple ib (Tuple b tb)) >>= flip J.append result
      makeDiv "<-" Nil >>= flip J.append result
      go p {expr:e, typ:te, idTree:ie} >>= flip J.append result
      pure result
  qualifier p (Let b e) (TLet tb te t) (TLet ib ie i) = do
      result <- makeDiv "let" Nil >>= addTypetoDiv t >>= addIdtoDiv i
      binding (Tuple ib (Tuple b tb)) >>= flip J.append result
      makeDiv "=" Nil >>= flip J.append result
      go p {expr:e, typ:te, idTree:ie} >>= flip J.append result
      pure result
  qualifier p (Guard e) (TGuard te t) (TGuard ie i) = go p {expr:e, typ:te, idTree:ie}
  qualifier _ _ _ _ = makeDiv "You found a Bug in Web.exprToJquery'.qualifier" Nil

checkLength :: forall a b c. List a -> List b -> List c -> Boolean
checkLength a b c = length a /= 0 && length a == length b && length a == length c && length b == length c

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

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

  _ -> makeDiv ("congrats you found a bug in Web.binding") Nil
  where
    consBinding :: Tuple IBinding (Tuple Binding  TypeBinding) -> J.JQuery-> Eff (dom :: DOM | eff) Unit
    consBinding (Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))) jCons = do
      binding (Tuple i1 (Tuple b tb)) >>= flip J.append jCons
      makeDiv ":" (singleton "colon") >>= flip J.append jCons
      consBinding (Tuple i2 (Tuple bs tbs)) jCons
    consBinding b jCons = void $ binding b >>= flip J.append jCons

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

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

unary:: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
unary jop jexpr t i = do
  jtypExp <- makeDiv "" (singleton "unary typExpContainer")
  jExpand <-  buildExpandDiv t
  J.append jExpand jtypExp
  jUnary <- makeDiv "" (singleton "unary expr")
  addTypetoDiv t jUnary
  addIdtoDiv i jUnary
  J.append jop jUnary
  J.append jexpr jUnary
  J.append jUnary jtypExp
  pure jtypExp

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

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

arithmeticSequence :: forall eff. J.JQuery -> Maybe J.JQuery -> Maybe J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
arithmeticSequence start mstep mend t i = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  das <- makeDiv "" (singleton "list expr")
  addTypetoDiv t das
  addIdtoDiv i das
  makeDiv "[" (singleton "brace") >>= flip J.append das
  J.append start das
  maybeStep das mstep
  makeDiv ".." (singleton "dot") >>= flip J.append das
  maybeEnd das mend
  makeDiv "]" (singleton "brace") >>= flip J.append das
  J.append das jtypExp
  pure jtypExp
  where
    maybeStep :: J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM | eff) Unit
    maybeStep jquery Nothing = pure unit
    maybeStep jquery (Just step) = do
      makeDiv "," (singleton "comma") >>= flip J.append jquery
      J.append step jquery

    maybeEnd :: J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM | eff) Unit
    maybeEnd jquery Nothing = pure unit
    maybeEnd jquery (Just end) = J.append end jquery

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

--TODO: create css entry for "let typExpContainer" and "let expr"
letExpr :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
letExpr jBinds jExpr t i = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  --jtypExp <- makeDiv "" (singleton "let typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dlet <- makeDiv "" (singleton "list expr")
  addTypetoDiv t dlet
  addIdtoDiv i dlet
  --dlet <- makeDiv "" (singleton "let expr") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "let" (singleton "keyword") >>= flip J.append dlet
  interleaveM_ (flip J.append dlet) (makeDiv ";" (singleton "semicolon") >>= flip J.append dlet) jBinds
  makeDiv "in" (singleton "keyword") >>= flip J.append dlet
  J.append jExpr dlet
  J.append dlet jtypExp
  pure jtypExp

letBinding :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
letBinding jBind jExpr = do
  jtypExp <- makeDiv "" (singleton "letBinding  typExpContainer")
  dlet <- makeDiv "" (singleton "letBinding  expr")
  J.append jBind dlet
  makeDiv "=" Nil >>= flip J.append dlet
  J.append jExpr dlet
  J.append dlet jtypExp
  pure jtypExp

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

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

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

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

string :: forall eff. String -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string str t i = do
  jtypExp <- makeDiv "" (singleton "list string typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jString <- makeDiv ("\"" <> str <> "\"") (Array.toUnfoldable ["list", "string", "expr"])
  addTypetoDiv t jString
  addIdtoDiv i jString
  J.append jString  jtypExp
  pure jtypExp

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

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs tFunc t i = do
  jtypExp <- makeDiv "" (singleton "app typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dApp <- makeDiv "" (singleton "app expr")
  addTypetoDiv t dApp
  addIdtoDiv i dApp
  J.addClass "func" jFunc
  J.addClass "funcContainer" jFunc
  innerExpr <- children ".expr" jFunc
  jExpand2 <- children ".expand" jFunc
  innerTyp <- children ".type" jExpand2
  typeArr <- children ".type-arr" jExpand2
  J.css {transform: "rotate(180deg)"} typeArr
  case tFunc of
    TypeError _ -> J.setVisible true innerTyp
    _ -> J.setVisible false innerTyp
  J.addClass "func" innerExpr
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  J.append dApp jtypExp
  pure jtypExp

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "<div></div>"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d

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

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  text <- J.getText d
  J.clear d
  outer <- makeDiv "" $ Cons "tooltip-outer" Nil
  inner <- makeDiv (prettyPrintType typ) $ Cons "tooltip-inner" Nil
  J.append inner outer
  J.append outer d
  J.appendText text d
  J.on "mouseenter" (\e div -> J.stopPropagation e >>= \_ -> showTooltip div outer e) d
  pure d

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

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

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

buildExpandDiv:: forall eff. Type  -> Eff (dom :: DOM | eff) J.JQuery
buildExpandDiv t  = do
  typC <- makeDiv ("::" <> prettyPrintType t) $ Cons "type" Nil
  case t of
    (TypeError _) -> do
      J.css {color: "red"} typC
      pure typC
    _ -> pure typC
  expandC <- makeDiv "" $ Cons "expand"  Nil
  jArrow <- makeDiv "▼" $ Cons "type-arr" Nil
  J.append jArrow expandC
  J.append typC expandC
  J.on "click" (\e _ -> do
      J.stopPropagation e
      J.setVisible true typC
      J.css {transform: "rotate(0deg)"} jArrow
      ) expandC
  J.on "click" (\e _ -> do
      J.stopPropagation e
      J.setVisible false typC
      J.css {transform: "rotate(180deg)"} jArrow
      ) typC
  J.on "mouseenter" (\e _ -> J.stopImmediatePropagation e) expandC -- otherwise tooltip shows
  J.on "mousemove" (\e _ -> J.stopImmediatePropagation e) expandC
  J.setAttr "title" "show Type" expandC
  J.setAttr "title" "hide Type" typC
  J.css {display: "inline-block"} typC
  pure expandC

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

mapM' :: forall a b m. (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapM' f Nothing  = pure Nothing
mapM' f (Just x) = Just <$> (f x)

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

indexQual :: ExprQual -> State {count :: Int} IndexQual
indexQual (Gen b e) = do
  b' <- indexBinding b
  e' <- indexExpr e
  i  <- fresh
  pure $ TGen b' e' i
indexQual (Let b e) = do
  b' <- indexBinding b
  e' <- indexExpr e
  i  <- fresh
  pure $ TLet b' e' i
indexQual (Guard e) = do
  e' <- indexExpr e
  i  <- fresh
  pure $ TGuard e' i

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

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

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

import Prelude (class Show, class Monad, Unit, (+), bind, ($), (==), (/=), show, (<>), (>>=), flip, pure, (<<<), (<$>), (&&), (>), void, unit, id, (-))
import Data.Foldable (all)
import Data.Traversable (for)
import Data.String (joinWith)
import Data.List (List(Nil, Cons), singleton, fromFoldable, toUnfoldable, length, zip, (..), zipWithA)
import Data.Foreign (unsafeFromForeign, isUndefined)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Array as Array

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
--import Control.Monad (when)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import Control.Monad.State (State, put, get, runState)
import DOM (DOM)

import AST (Atom(..), Binding(..), Expr(..), Qual(..), ExprQual, TypeQual, IndexQual, QualTree(..), Op(), pPrintOp, Output(),Type(..), IndexTree(..),IBinding(..),TypeTree(..),TypeBinding(..), Path(..), extractType)
import TypeChecker (prettyPrintType, mapM)
import JSHelpers (showTooltip, children)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) (Maybe Path)
getPath j = do
  fpath <- J.getProp pathPropName j
  if isUndefined fpath
    then pure Nothing
    else pure $ Just $ unsafeFromForeign fpath

exprToJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go (output.expr)
  where
    go (Atom (Name _)) = exprToJQuery' output
    go (Atom _) = topLevel
    go (Binary _ _ _) = exprToJQuery' output
    go (PrefixOp _) = topLevel
    go _ = exprToJQuery' output

    topLevel = case extractType output.typ of
        TypeError _ -> exprToJQuery' output
        _ -> do
          jtypExp <- makeDiv "" (singleton "top typExpContainer")
          jExpand <- buildExpandDiv (extractType output.typ)
          J.append jExpand jtypExp
          jExpr <- exprToJQuery' output
          J.addClass "expr" jExpr
          J.append jExpr jtypExp
          pure jtypExp

-- TODO rename to fit new Type
exprToJQuery' :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery' output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o =
    (\jObj -> do
          let f = J.setProp pathPropName (p End)
          jExpr <- children ".expr" jObj
          isNotEmpty <- J.hasClass "expr" jExpr
          if isNotEmpty then f jExpr else f jObj
          pure jObj
          )
    =<<
    case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2
    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case toStr es of
                  Just str  -> string str t i
                  Nothing -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                                list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" <> pPrintOp op <> ")") (toUnfoldable ["prefix", "op"]) >>= addTypetoDiv t >>= addIdtoDiv i
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i

    {expr:(ArithmSeq start step end), typ:(TArithmSeq tstart tstep tend t), idTree:(IArithmSeq istart istep iend i)} -> do
      jStart <- go (p <<< Fst)  {expr:start, typ:tstart, idTree:istart}
      case (isJust step) && (isJust tstep) && (isJust istep) of
        true  -> case (isJust end) && (isJust tend) && (isJust iend) of
          true  -> do
            jStep <- go (p <<< Snd) {expr:(fromJust step), typ:(fromJust tstep), idTree:(fromJust istep)}
            jEnd  <- go (p <<< Thrd) {expr:(fromJust end), typ:(fromJust tend), idTree:(fromJust iend)}
            arithmeticSequence jStart (Just jStep) (Just jEnd) t i
          false -> do
            jStep <- go (p <<< Snd) {expr:(fromJust step), typ:(fromJust tstep), idTree:(fromJust istep)}
            arithmeticSequence jStart (Just jStep) Nothing t i
        false -> case (isJust end) && (isJust tend) && (isJust iend) of
          true  -> do
            jEnd  <- go (p <<< Thrd) {expr:(fromJust end), typ:(fromJust tend), idTree:(fromJust iend)}
            arithmeticSequence jStart Nothing (Just jEnd) t i
          false -> do
            arithmeticSequence jStart Nothing Nothing t i

    {expr:(ListComp expr quals), typ:(TListComp texpr tquals t), idTree:(IListComp iexpr iquals i)} -> do
      jExpr  <- go (p <<< Fst) {expr:expr, typ:texpr, idTree:iexpr}
      jQuals <- zipWithA (\i (Tuple i' (Tuple e t)) -> qualifier (p <<< Nth i) e t i')
        (0 .. (length quals - 1)) (zip iquals (zip quals tquals))
      listComp jExpr jQuals t i

    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs (extractType tt) t i
    {expr: Unary op exp, typ: TUnary opt tt t, idTree:IUnary opi is i} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      jexpr <- go (p <<< Fst) {expr: exp, typ: tt, idTree: is}
      unary jop jexpr t i

    {expr: LetExpr binds exp, typ: TLetExpr tbinds texp t, idTree: ILetExpr ibinds iexp i} -> case checkLength binds tbinds ibinds of
      false -> makeDiv "oops! LetExpr bindings length error!" Nil
      true  -> do
        let fstBoundle = zip (fst <$> ibinds) (zip (fst <$> binds) (fst <$> tbinds))
            sndBoundle = zip (snd <$> ibinds) (zip (snd <$> binds) (snd <$> tbinds))

        jbinds <- mapM binding fstBoundle
        jexprs <- zipWithA (\x (Tuple i (Tuple b t)) -> go (p <<< Nth x) {expr: b, typ: t, idTree: i}) (1 .. (length sndBoundle)) sndBoundle
        jletBinds <- zipWithA letBinding jbinds jexprs

        jexpr <- go (p <<< Fst) {expr: exp, typ: texp, idTree: iexp}
        letExpr jletBinds jexpr t i

    {} -> makeDiv "You found a Bug" Nil

  qualifier :: (Path -> Path) -> ExprQual -> TypeQual -> IndexQual -> Eff (dom :: DOM | eff) J.JQuery
  qualifier p (Gen b e) (TGen tb te t) (TGen ib ie i) = do
      result <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
      binding (Tuple ib (Tuple b tb)) >>= flip J.append result
      makeDiv "<-" Nil >>= flip J.append result
      go p {expr:e, typ:te, idTree:ie} >>= flip J.append result
      pure result
  qualifier p (Let b e) (TLet tb te t) (TLet ib ie i) = do
      result <- makeDiv "let" Nil >>= addTypetoDiv t >>= addIdtoDiv i
      binding (Tuple ib (Tuple b tb)) >>= flip J.append result
      makeDiv "=" Nil >>= flip J.append result
      go p {expr:e, typ:te, idTree:ie} >>= flip J.append result
      pure result
  qualifier p (Guard e) (TGuard te t) (TGuard ie i) = go p {expr:e, typ:te, idTree:ie}
  qualifier _ _ _ _ = makeDiv "You found a Bug in Web.exprToJquery'.qualifier" Nil

checkLength :: forall a b c. List a -> List b -> List c -> Boolean
checkLength a b c = length a /= 0 && length a == length b && length a == length c && length b == length c

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

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

  _ -> makeDiv ("congrats you found a bug in Web.binding") Nil
  where
    consBinding :: Tuple IBinding (Tuple Binding  TypeBinding) -> J.JQuery-> Eff (dom :: DOM | eff) Unit
    consBinding (Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))) jCons = do
      binding (Tuple i1 (Tuple b tb)) >>= flip J.append jCons
      makeDiv ":" (singleton "colon") >>= flip J.append jCons
      consBinding (Tuple i2 (Tuple bs tbs)) jCons
    consBinding b jCons = void $ binding b >>= flip J.append jCons

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

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

unary:: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
unary jop jexpr t i = do
  jtypExp <- makeDiv "" (singleton "unary typExpContainer")
  jExpand <-  buildExpandDiv t
  J.append jExpand jtypExp
  jUnary <- makeDiv "" (singleton "unary expr") >>= addTypetoDiv t >>= addIdtoDiv i
  J.append jop jUnary
  J.append jexpr jUnary
  J.append jUnary jtypExp
  pure jtypExp

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

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

arithmeticSequence :: forall eff. J.JQuery -> Maybe J.JQuery -> Maybe J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
arithmeticSequence start mstep mend t i = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  das <- makeDiv "" (singleton "list expr") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "[" (singleton "brace") >>= flip J.append das
  J.append start das
  maybeStep das mstep
  makeDiv ".." (singleton "dot") >>= flip J.append das
  maybeEnd das mend
  makeDiv "]" (singleton "brace") >>= flip J.append das
  J.append das jtypExp
  pure jtypExp
  where
    maybeStep :: J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
    maybeStep jquery Nothing = pure jquery
    maybeStep jquery (Just step) = do
      makeDiv "," (singleton "comma") >>= flip J.append jquery
      J.append step jquery

    maybeEnd :: J.JQuery -> Maybe J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
    maybeEnd jquery Nothing = pure jquery
    maybeEnd jquery (Just end) = J.append end jquery

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

--TODO: create css entry for "let typExpContainer" and "let expr"
letExpr :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
letExpr jBinds jExpr t i = do
  jtypExp <- makeDiv "" (singleton "list typExpContainer")
  --jtypExp <- makeDiv "" (singleton "let typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dlet <- makeDiv "" (singleton "list expr") >>= addTypetoDiv t >>= addIdtoDiv i
  --dlet <- makeDiv "" (singleton "let expr") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "let" (singleton "keyword") >>= flip J.append dlet
  interleaveM_ (flip J.append dlet) (makeDiv ";" (singleton "semicolon") >>= flip J.append dlet) jBinds
  makeDiv "in" (singleton "keyword") >>= flip J.append dlet
  J.append jExpr dlet
  J.append dlet jtypExp
  pure jtypExp

letBinding :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
letBinding jBind jExpr = do
  jtypExp <- makeDiv "" (singleton "letBinding  typExpContainer")
  dlet <- makeDiv "" (singleton "letBinding  expr")
  J.append jBind dlet
  makeDiv "=" Nil >>= flip J.append dlet
  J.append jExpr dlet
  J.append dlet jtypExp
  pure jtypExp

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

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

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

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

string :: forall eff. String -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string str t i = do
  jtypExp <- makeDiv "" (singleton "list string typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  jString <- makeDiv ("\"" <> str <> "\"") (toUnfoldable ["list", "string", "expr"]) >>= addTypetoDiv t >>= addIdtoDiv i
  J.append jString  jtypExp

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

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs tFunc t i = do
  jtypExp <- makeDiv "" (singleton "app typExpContainer")
  jExpand <- buildExpandDiv t
  J.append jExpand jtypExp
  dApp <- makeDiv "" (singleton "app expr") >>= addTypetoDiv t >>= addIdtoDiv i
  J.addClass "func" jFunc
  J.addClass "funcContainer" jFunc
  innerExpr <- children ".expr" jFunc
  jExpand2 <- children ".expand" jFunc
  innerTyp <- children ".type" jExpand2
  typeArr <- children ".type-arr" jExpand2
  J.css {transform: "rotate(180deg)"} typeArr
  case tFunc of
    TypeError _ -> J.setVisible true innerTyp
    _ -> J.setVisible false innerTyp
  J.addClass "func" innerExpr
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  J.append dApp jtypExp
  pure jtypExp

type Class = String

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

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

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

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  text <- J.getText d
  J.clear d
  outer <- makeDiv "" $ Cons "tooltip-outer" Nil
  inner <- makeDiv (prettyPrintType typ) $ Cons "tooltip-inner" Nil
  J.append inner outer
  J.append outer d
  J.appendText text d
  J.on "mouseenter" (\e div -> J.stopPropagation e >>= \_ -> showTooltip div outer e) d

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

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

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

buildExpandDiv:: forall eff. Type  -> Eff (dom :: DOM | eff) J.JQuery
buildExpandDiv t  = do
  typC <- makeDiv ("::" <> prettyPrintType t) $ Cons "type" Nil
  case t of
    (TypeError _) -> J.css {color: "red"} typC
    _ -> pure typC
  expandC <- makeDiv "" $ Cons "expand"  Nil
  jArrow <- makeDiv "▼" $ Cons "type-arr" Nil
  J.append jArrow expandC
  J.append typC expandC
  J.on "click" (\e _ -> do
      J.stopPropagation e
      J.setVisible true typC
      J.css {transform: "rotate(0deg)"} jArrow
      ) expandC
  J.on "click" (\e _ -> do
      J.stopPropagation e
      J.setVisible false typC
      J.css {transform: "rotate(180deg)"} jArrow
      ) typC
  J.on "mouseenter" (\e _ -> J.stopImmediatePropagation e) expandC -- otherwise tooltip shows
  J.on "mousemove" (\e _ -> J.stopImmediatePropagation e) expandC
  J.setAttr "title" "show Type" expandC
  J.setAttr "title" "hide Type" typC
  J.css {display: "inline-block"} typC
  pure expandC

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

mapM' :: forall a b m. (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapM' f Nothing  = pure Nothing
mapM' f (Just x) = Just <$> (f x)

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

indexQual :: ExprQual -> State {count :: Int} IndexQual
indexQual (Gen b e) = do
  b' <- indexBinding b
  e' <- indexExpr e
  i  <- fresh
  pure $ TGen b' e' i
indexQual (Let b e) = do
  b' <- indexBinding b
  e' <- indexExpr e
  i  <- fresh
  pure $ TLet b' e' i
indexQual (Guard e) = do
  e' <- indexExpr e
  i  <- fresh
  pure $ TGuard e' i

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

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


added highlightning function

added highlightning function

module Web where

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

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

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

import AST as AST

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

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

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

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

-- Given a Highlight value and the Meta information of a node, generated additional classes to highlight the node
highlight' :: Highlight -> Meta -> List String
highlight' { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp :: Maybe Int -> Maybe Boolean
   cmp = map (\i -> m.index == i)

highlight :: Highlight -> Meta -> Div -> Div
highlight hl meta (Node a chs) = Node (a { classes = highlight' hl meta <> a.classes }) chs

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

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

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

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

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

exprToDiv :: Highlight -> TypeTree -> Div
exprToDiv hl = go id
  where
    h :: Meta -> Div -> Div
    h = highlight hl

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

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

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

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

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

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

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

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

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

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

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

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

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

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  J.append div container

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

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

  if needsContainer
    then pure container
    else pure div

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

type Class = String

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

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

module Web where

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

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

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

import AST as AST

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

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

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

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

-- Given a Highlight value and the Meta information of a node, generated additional classes to highlight the node
highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp :: Maybe Int -> Maybe Boolean
   cmp = map (\i -> m.index == i)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  J.append div container

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

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

  if needsContainer
    then pure container
    else pure div

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

type Class = String

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

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