defined the Highlight type

defined the Highlight type

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:))
import Data.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 }

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 AST.emptyMeta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple AST.emptyMeta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary AST.emptyMeta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL AST.emptyMeta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR AST.emptyMeta 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 AST.emptyMeta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr AST.emptyMeta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr AST.emptyMeta 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 AST.emptyMeta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr AST.emptyMeta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda AST.emptyMeta binds) body) expr hole

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

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

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App AST.emptyMeta func args
        argsDivs = zipList go (hole <<< App AST.emptyMeta 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, (:))
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(..),
            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

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 AST.emptyMeta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple AST.emptyMeta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary AST.emptyMeta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary AST.emptyMeta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL AST.emptyMeta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR AST.emptyMeta 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 AST.emptyMeta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr AST.emptyMeta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr AST.emptyMeta 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 AST.emptyMeta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr AST.emptyMeta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda AST.emptyMeta binds) body) expr hole

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

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

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App AST.emptyMeta func args
        argsDivs = zipList go (hole <<< App AST.emptyMeta 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


Naming and comments

Naming and comments

-- Highly experimental (and naive) implementation of servant-server style
-- routing for Hyper.
module Hyper.Routing.TypeLevelRouter
       ( Lit
       , Capture
       , CaptureAll
       , Handler
       , Get
       , Sub
       , LitSub
       , AltE(..)
       , type (:>)
       , type (:/)
       , type (:<|>)
       , (:<|>)
       , Link
       , class HasLinks
       , toLinks
       , linksTo
       , RoutingError(..)
       , class Router
       , route
       , router
       ) where

import Prelude
import Control.Monad.Error.Class (throwError)
import Data.Array (elem, filter, foldl, null, singleton, uncons, unsnoc)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Path.Pathy (dir, file, rootDir, (</>))
import Data.String (Pattern(..), split)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.URI (HierarchicalPart(..), URI(..))
import Hyper.Core (class ResponseWriter, Conn, Middleware, ResponseEnded, Status, StatusLineOpen, TryMiddleware(..), closeHeaders, statusBadRequest, statusMethodNotAllowed, statusNotFound, writeStatus)
import Hyper.Method (Method)
import Hyper.Response (class Response, respond)
import Hyper.Routing.PathPiece (class FromPathPiece, class ToPathPiece, fromPathPiece, toPathPiece)
import Type.Proxy (Proxy(..))

-- | A literal path segment, matching paths where the next segment is equal
-- | to the value of the `Symbol`.
-- |
-- | For example, the type `Lit "settings" :> Lit "general" :> "reset"`  would
-- | match the path `/settings/general/reset`.
data Lit (v :: Symbol)

-- | Captures one segment of a path as type `t`. The `v` is a
-- | `Symbol` that describes the captured value.
data Capture (v :: Symbol) t

-- | Captures all remaining segments of a path, all as type `t`. The `v`
-- | is a `Symbol` that describes
data CaptureAll (v :: Symbol) t

-- | A type-level description of the handler function, terminating a chain of
-- | path literals, captures, and other endpoint type constructs. The `m` symbol
-- | is the HTTP method that is handled.
data Handler (m :: Symbol)

-- | Handy alias for GET handlers.
type Get = Handler "GET"

-- | The `Sub` is used to create the chain of `Lit`, `Capture`, `Handler`,
-- | and other such type constructs that build up an endpoint type. `Sub`
-- | is more often used infix with the `:>` operator.
data Sub e t

-- | A handy type alias for `Sub (Lit v)`, meant to be used infix with the `:/`
-- | operator. Instead of writing `Lit "a" :> Lit "b" :> ...`, you can write
-- | `"a" :/ "b" :/ ...`.
type LitSub (v :: Symbol) t = Sub (Lit v) t

-- | `AltE`` respresents choice, i.e. that endpoint `a` is tried first, and if
-- | it fails, `b` is tried next. `AltE` is written infix using `:<|>` and is
-- | used to compose multiple endpoint types into a larger API or site. It is
-- | used to build up recursive structures, so `AltE a (AltE b c)` can be
-- | written `a :<|> b :<|> c`.
-- |
-- | It it also used to extract information from a type, where the information
-- | has the same structure as the type. For instance, when extracting links
-- | from an `AltE` type, you can pattern match the result using `:<|>`
-- | to access the links of `a` and `b`. That also works recursively with a
-- | pattern match like `a :<|> b :<|> c :<|> d`.
data AltE a b = AltE a b

infixr 5 type Sub as :>
infixr 5 type LitSub as :/
infixl 4 type AltE as :<|>
infixl 4 AltE as :<|>

newtype Link = Link (Array String)

instance monoidLink :: Monoid Link where
  mempty = Link []

instance semigroupLink :: Semigroup Link where
  append (Link p1) (Link p2) = Link (p1 <> p2)

derive instance newtypeLink :: Newtype Link _

derive instance genericLink :: Generic Link _

instance eqLink :: Eq Link where
  eq = genericEq

linkToURI :: Link -> URI
linkToURI (Link segments) =
  URI
  Nothing
  (HierarchicalPart Nothing (Just path))
  Nothing
  Nothing
  where
    path =
      case unsnoc segments of
        Just { init, last } ->
          Right (foldl (</>) rootDir (map dir init) </> file last)
        Nothing ->
          Left rootDir

class HasLinks e mk | e -> mk where
  toLinks :: Proxy e -> Link -> mk

instance hasLinksLit :: (HasLinks sub subMk, IsSymbol lit)
                       => HasLinks (Lit lit :> sub) subMk where
  toLinks _ =
    toLinks (Proxy :: Proxy sub) <<< flip append (Link [segment])
    where
      segment = reflectSymbol (SProxy :: SProxy lit)

instance hasLinksCapture :: (HasLinks sub subMk, IsSymbol c, ToPathPiece t)
                           => HasLinks (Capture c t :> sub) (t -> subMk) where
  toLinks _ l =
    toLinks (Proxy :: Proxy sub) <<< append l <<< Link <<< singleton <<< toPathPiece

instance hasLinksCaptureAll :: (HasLinks sub subMk, IsSymbol c, ToPathPiece t)
                              => HasLinks (CaptureAll c t :> sub) (Array t -> subMk) where
  toLinks _ l =
    toLinks (Proxy :: Proxy sub) <<< append l <<< Link <<< map toPathPiece

instance hasLinksHandler :: HasLinks (Handler m) URI where
  toLinks _ = linkToURI

instance hasLinksAltE :: (HasLinks e1 mk1, HasLinks e2 mk2) => HasLinks (e1 :<|> e2) (mk1 :<|> mk2) where
  toLinks _ link =
    toLinks (Proxy :: Proxy e1) link
    :<|> toLinks (Proxy :: Proxy e2) link

linksTo :: forall e t. HasLinks e t => Proxy e -> t
linksTo e = toLinks e mempty

type RoutingContext = { path :: (Array String)
                      , method :: Method
                      }

data RoutingError
  = HTTPError Status (Maybe String)

derive instance genericRoutingError :: Generic RoutingError _

instance eqRoutingError :: Eq RoutingError where
  eq = genericEq

instance showRoutingError :: Show RoutingError where
  show = genericShow

class Router e h r | e -> h, e -> r where
  route :: Proxy e -> RoutingContext -> h -> Either RoutingError r

fallthrough :: RoutingError -> Boolean
fallthrough (HTTPError (Tuple code _) _) = code `elem` [404, 405]

instance routerAltE :: (Router e1 h1 out, Router e2 h2 out)
                            => Router (e1 :<|> e2) (h1 :<|> h2) out where
  route _ context (h1 :<|> h2) =
    case route (Proxy :: Proxy e1) context h1 of
      Left err ->
        if fallthrough err
        then route (Proxy :: Proxy e2) context h2
        else Left err
      Right handler -> pure handler

instance routerLit :: (Router e h out, IsSymbol lit)
                      => Router (Lit lit :> e) h out where
  route _ ctx r =
    case uncons ctx.path of
      Just { head, tail } | head == expectedSegment ->
        route (Proxy :: Proxy e) ctx { path = tail} r
      Just _ -> throwError (HTTPError statusNotFound Nothing)
      Nothing -> throwError (HTTPError statusNotFound Nothing)
    where expectedSegment = reflectSymbol (SProxy :: SProxy lit)

instance routerCapture :: (Router e h out, FromPathPiece v)
                          => Router (Capture c v :> e) (v -> h) out where
  route _ ctx r =
    case uncons ctx.path of
      Nothing -> throwError (HTTPError statusNotFound Nothing)
      Just { head, tail } ->
        case fromPathPiece head of
          Left err -> throwError (HTTPError statusBadRequest (Just err))
          Right x -> route (Proxy :: Proxy e) ctx { path = tail } (r x)

instance routerCaptureAll :: (Router e h out, FromPathPiece v)
                             => Router (CaptureAll c v :> e) (Array v -> h) out where
  route _ ctx r =
    case traverse fromPathPiece ctx.path of
      Left err -> throwError (HTTPError statusBadRequest (Just err))
      Right xs -> route (Proxy :: Proxy e) ctx { path = [] } (r xs)

instance routerHandler :: (IsSymbol m)
                       => Router (Handler m) h h where
  route _ context r =
    if expectedMethod == show context.method && null context.path
    then pure r
    else throwError (HTTPError
                     statusMethodNotAllowed
                     (Just ("Method "
                            <> show context.method
                            <> " did not match "
                            <> expectedMethod
                            <> ".")))
    where
      expectedMethod = reflectSymbol (SProxy :: SProxy m)

router
  :: forall s r m req res c rw b.
     ( Monad m
     , ResponseWriter rw m b
     , Response b m String
     , Router s r (Middleware
                   m
                   (Conn { method :: Method, url :: String | req } { writer :: rw StatusLineOpen | res } c)
                   (Conn { method :: Method, url :: String | req } { writer :: rw ResponseEnded | res } c))
     ) =>
     Proxy s
  -> r
  -> TryMiddleware
     m
     (Conn { method :: Method, url :: String | req } { writer :: rw StatusLineOpen | res } c)
     (Conn { method :: Method, url :: String | req } { writer :: rw ResponseEnded | res } c)
router _ handler = TryMiddleware router'
  where
    router' conn =
      case route (Proxy :: Proxy s) { path: splitUrl conn.request.url
                                    , method: conn.request.method
                                    } handler of
        Left (HTTPError (Tuple 404 _) _) ->
          pure Nothing
        Left (HTTPError status msg) ->
          writeStatus status conn
          >>= closeHeaders
          >>= respond (maybe "" id msg)
          # map Just
        Right h ->
          Just <$> h conn
    splitUrl = filter ((/=) "") <<< split (Pattern "/")

-- Highly experimental and naive implementation of servant-server style
-- routing for Hyper. Not much will be stable here.
module Hyper.Routing.TypeLevelRouter
       ( Lit
       , Capture
       , CaptureAll
       , Verb
       , Get
       , Sub
       , LitSub
       , Endpoints(..)
       , type (:>)
       , type (:/)
       , type (:<|>)
       , (:<|>)
       , Link
       , class HasLinks
       , toLinks
       , linksTo
       , RoutingError(..)
       , class Router
       , route
       , router
       ) where

import Prelude
import Control.Monad.Error.Class (throwError)
import Data.Array (elem, filter, foldl, null, singleton, uncons, unsnoc)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Path.Pathy (dir, file, rootDir, (</>))
import Data.String (Pattern(..), split)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.URI (HierarchicalPart(..), URI(..))
import Hyper.Core (class ResponseWriter, Conn, Middleware, ResponseEnded, Status, StatusLineOpen, TryMiddleware(..), closeHeaders, statusBadRequest, statusMethodNotAllowed, statusNotFound, writeStatus)
import Hyper.Method (Method)
import Hyper.Response (class Response, respond)
import Hyper.Routing.PathPiece (class FromPathPiece, class ToPathPiece, fromPathPiece, toPathPiece)
import Type.Proxy (Proxy(..))

data Lit (v :: Symbol)
data Capture (v :: Symbol) t
data CaptureAll (v :: Symbol) t

data Verb (m :: Symbol)

type Get = Verb "GET"

data Sub e t
type LitSub (v :: Symbol) t = Sub (Lit v) t

data Endpoints a b = Endpoints a b

infixr 5 type Sub as :>
infixr 5 type LitSub as :/
infixl 4 type Endpoints as :<|>
infixl 4 Endpoints as :<|>

newtype Link = Link (Array String)

instance monoidLink :: Monoid Link where
  mempty = Link []

instance semigroupLink :: Semigroup Link where
  append (Link p1) (Link p2) = Link (p1 <> p2)

derive instance newtypeLink :: Newtype Link _

derive instance genericLink :: Generic Link _

instance eqLink :: Eq Link where
  eq = genericEq

linkToURI :: Link -> URI
linkToURI (Link segments) =
  URI
  Nothing
  (HierarchicalPart Nothing (Just path))
  Nothing
  Nothing
  where
    path =
      case unsnoc segments of
        Just { init, last } ->
          Right (foldl (</>) rootDir (map dir init) </> file last)
        Nothing ->
          Left rootDir

class HasLinks e mk | e -> mk where
  toLinks :: Proxy e -> Link -> mk

instance hasLinksLit :: (HasLinks sub subMk, IsSymbol lit)
                       => HasLinks (Lit lit :> sub) subMk where
  toLinks _ =
    toLinks (Proxy :: Proxy sub) <<< flip append (Link [segment])
    where
      segment = reflectSymbol (SProxy :: SProxy lit)

instance hasLinksCapture :: (HasLinks sub subMk, IsSymbol c, ToPathPiece t)
                           => HasLinks (Capture c t :> sub) (t -> subMk) where
  toLinks _ l =
    toLinks (Proxy :: Proxy sub) <<< append l <<< Link <<< singleton <<< toPathPiece

instance hasLinksCaptureAll :: (HasLinks sub subMk, IsSymbol c, ToPathPiece t)
                              => HasLinks (CaptureAll c t :> sub) (Array t -> subMk) where
  toLinks _ l =
    toLinks (Proxy :: Proxy sub) <<< append l <<< Link <<< map toPathPiece

instance hasLinksVerb :: HasLinks (Verb m) URI where
  toLinks _ = linkToURI

instance hasLinksEndpoints :: (HasLinks e1 mk1, HasLinks e2 mk2) => HasLinks (e1 :<|> e2) (mk1 :<|> mk2) where
  toLinks _ link =
    toLinks (Proxy :: Proxy e1) link
    :<|> toLinks (Proxy :: Proxy e2) link

linksTo :: forall e t. HasLinks e t => Proxy e -> t
linksTo e = toLinks e mempty

type RoutingContext = { path :: (Array String)
                      , method :: Method
                      }

data RoutingError
  = HTTPError Status (Maybe String)

derive instance genericRoutingError :: Generic RoutingError _

instance eqRoutingError :: Eq RoutingError where
  eq = genericEq

instance showRoutingError :: Show RoutingError where
  show = genericShow

class Router e h r | e -> h, e -> r where
  route :: Proxy e -> RoutingContext -> h -> Either RoutingError r

fallthrough :: RoutingError -> Boolean
fallthrough (HTTPError (Tuple code _) _) = code `elem` [404, 405]

instance routerEndpoints :: (Router e1 h1 out, Router e2 h2 out)
                            => Router (e1 :<|> e2) (h1 :<|> h2) out where
  route _ context (h1 :<|> h2) =
    case route (Proxy :: Proxy e1) context h1 of
      Left err ->
        if fallthrough err
        then route (Proxy :: Proxy e2) context h2
        else Left err
      Right handler -> pure handler

instance routerLit :: (Router e h out, IsSymbol lit)
                      => Router (Lit lit :> e) h out where
  route _ ctx r =
    case uncons ctx.path of
      Just { head, tail } | head == expectedSegment ->
        route (Proxy :: Proxy e) ctx { path = tail} r
      Just _ -> throwError (HTTPError statusNotFound Nothing)
      Nothing -> throwError (HTTPError statusNotFound Nothing)
    where expectedSegment = reflectSymbol (SProxy :: SProxy lit)

instance routerCapture :: (Router e h out, FromPathPiece v)
                          => Router (Capture c v :> e) (v -> h) out where
  route _ ctx r =
    case uncons ctx.path of
      Nothing -> throwError (HTTPError statusNotFound Nothing)
      Just { head, tail } ->
        case fromPathPiece head of
          Left err -> throwError (HTTPError statusBadRequest (Just err))
          Right x -> route (Proxy :: Proxy e) ctx { path = tail } (r x)

instance routerCaptureAll :: (Router e h out, FromPathPiece v)
                             => Router (CaptureAll c v :> e) (Array v -> h) out where
  route _ ctx r =
    case traverse fromPathPiece ctx.path of
      Left err -> throwError (HTTPError statusBadRequest (Just err))
      Right xs -> route (Proxy :: Proxy e) ctx { path = [] } (r xs)

instance routerVerb :: (IsSymbol m)
                       => Router (Verb m) h h where
  route _ context r =
    if expectedMethod == show context.method && null context.path
    then pure r
    else throwError (HTTPError
                     statusMethodNotAllowed
                     (Just ("Method "
                            <> show context.method
                            <> " did not match "
                            <> expectedMethod
                            <> ".")))
    where
      expectedMethod = reflectSymbol (SProxy :: SProxy m)

router
  :: forall s r m req res c rw b.
     ( Monad m
     , ResponseWriter rw m b
     , Response b m String
     , Router s r (Middleware
                   m
                   (Conn { method :: Method, url :: String | req } { writer :: rw StatusLineOpen | res } c)
                   (Conn { method :: Method, url :: String | req } { writer :: rw ResponseEnded | res } c))
     ) =>
     Proxy s
  -> r
  -> TryMiddleware
     m
     (Conn { method :: Method, url :: String | req } { writer :: rw StatusLineOpen | res } c)
     (Conn { method :: Method, url :: String | req } { writer :: rw ResponseEnded | res } c)
router _ handler = TryMiddleware router'
  where
    router' conn =
      case route (Proxy :: Proxy s) { path: splitUrl conn.request.url
                                    , method: conn.request.method
                                    } handler of
        Left (HTTPError (Tuple 404 _) _) ->
          pure Nothing
        Left (HTTPError status msg) ->
          writeStatus status conn
          >>= closeHeaders
          >>= respond (maybe "" id msg)
          # map Just
        Right h ->
          Just <$> h conn
    splitUrl = filter ((/=) "") <<< split (Pattern "/")


Make exports explicit to hide FFI implementations

-- | A module providing a type and operations for the native JavaScript `Date`
-- | object.
-- |
-- | The `JSDate` type and associated functions are provided for interop
-- | purposes with JavaScript, but for working with dates in PureScript it is
-- | recommended that `DateTime` representation is used instead - `DateTime`
-- | offers greater type safety, a more PureScript-friendly interface, and has
-- | a `Generic` instance.
module Data.JSDate
  ( JSDate
  , LOCALE
  , readDate
  , isValid
  , fromDateTime
  , toDateTime
  , toDate
  , toInstant
  , jsdate
  , jsdateLocal
  , parse
  , getTime
  , getUTCDate
  , getUTCDay
  , getUTCFullYear
  , getUTCHours
  , getUTCMilliseconds
  , getUTCMinutes
  , getUTCMonth
  , getUTCSeconds
  , getDate
  , getDay
  , getFullYear
  , getHours
  , getMilliseconds
  , getMinutes
  , getMonth
  , getSeconds
  , getTimezoneOffset
  , toDateString
  , toISOString
  , toString
  , toTimeString
  , toUTCString
  ) where

import Prelude

import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Date as Date
import Data.DateTime (DateTime(..), Date)
import Data.DateTime as DateTime
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Enum (fromEnum)
import Data.Foreign (F, Foreign, unsafeReadTagged)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Time as Time
import Data.Time.Duration (Milliseconds(..))

-- | The type of JavaScript `Date` objects.
foreign import data JSDate :: Type

-- | The effect type used when indicating the current machine's date/time locale
-- | is used in computing a value.
foreign import data LOCALE :: Effect

-- | Attempts to read a `Foreign` value as a `JSDate`.
readDate :: Foreign -> F JSDate
readDate = unsafeReadTagged "Date"

-- | Checks whether a date value is valid. When a date is invalid, the majority
-- | of the functions return `NaN`, `"Invalid Date"`, or throw an exception.
foreign import isValid :: JSDate -> Boolean

-- | Converts a `DateTime` value into a native JavaScript date object. The
-- | resulting date value is guaranteed to be valid.
fromDateTime :: DateTime -> JSDate
fromDateTime (DateTime d t) = jsdate
  { year: toNumber (fromEnum (Date.year d))
  , month: toNumber (fromEnum (Date.month d) - 1)
  , day: toNumber (fromEnum (Date.day d))
  , hour: toNumber (fromEnum (Time.hour t))
  , minute: toNumber (fromEnum (Time.minute t))
  , second: toNumber (fromEnum (Time.second t))
  , millisecond: toNumber (fromEnum (Time.millisecond t))
  }

-- | Attempts to construct a `DateTime` value for a `JSDate`. `Nothing` is
-- | returned only when the date value is an invalid date.
toDateTime :: JSDate -> Maybe DateTime
toDateTime = map Instant.toDateTime <$> toInstant

-- | Attempts to construct a `Date` value for a `JSDate`, ignoring any time
-- | component of the `JSDate`. `Nothing` is returned only when the date value
-- | is an invalid date.
toDate :: JSDate -> Maybe Date
toDate = map DateTime.date <$> toDateTime

-- | Attempts to construct an `Instant` for a `JSDate`. `Nothing` is returned
-- | only when the date value is an invalid date.
toInstant :: JSDate -> Maybe Instant
toInstant = Instant.instant <<< Milliseconds <=< toInstantImpl Just Nothing

foreign import toInstantImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> JSDate
  -> Maybe Number

-- | Constructs a new `JSDate` from UTC component values. If any of the values
-- | are `NaN` the resulting date will be invalid.
foreign import jsdate
  :: { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> JSDate

-- | Constructs a new `JSDate` from component values using the current machine's
-- | locale. If any of the values are `NaN` the resulting date will be invalid.
foreign import jsdateLocal
  :: forall eff
   . { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> Eff (locale :: LOCALE | eff) JSDate

foreign import dateMethodEff :: forall eff a. Fn2 String JSDate (Eff eff a)
foreign import dateMethod :: forall a. Fn2 String JSDate a

-- | Attempts to parse a date from a string. The behaviour of this function is
-- | implementation specific until ES5, so may not always have the same
-- | behaviour for a given string. The RFC2822 and ISO8601 date string formats
-- | should parse consistently.
-- |
-- | The `LOCALE` effect is present here as if no time zone is specified in the
-- | string the current locale's time zone will be used instead.
foreign import parse
  :: forall eff. String -> Eff (locale :: LOCALE | eff) JSDate

-- | Returns the date as a number of milliseconds since 1970-01-01 00:00:00 UTC.
getTime :: JSDate -> Number
getTime dt = runFn2 dateMethod "getTime" dt

-- | Returns the day of the month for a date, according to UTC.
getUTCDate :: JSDate -> Number
getUTCDate dt = runFn2 dateMethod "getUTCDate" dt

-- | Returns the day of the week for a date, according to UTC.
getUTCDay :: JSDate -> Number
getUTCDay dt = runFn2 dateMethod "getUTCDay" dt

-- | Returns the year for a date, according to UTC.
getUTCFullYear :: JSDate -> Number
getUTCFullYear dt = runFn2 dateMethod "getUTCFullYear" dt

-- | Returns the hours for a date, according to UTC.
getUTCHours :: JSDate -> Number
getUTCHours dt = runFn2 dateMethod "getUTCHours" dt

-- | Returns the milliseconds for a date, according to UTC.
getUTCMilliseconds :: JSDate -> Number
getUTCMilliseconds dt = runFn2 dateMethod "getUTCMilliseconds" dt

-- | Returns the minutes for a date, according to UTC.
getUTCMinutes :: JSDate -> Number
getUTCMinutes dt = runFn2 dateMethod "getUTCMinutes" dt

-- | Returns the month for a date, according to UTC.
getUTCMonth :: JSDate -> Number
getUTCMonth dt = runFn2 dateMethod "getUTCMonth" dt

-- | Returns the seconds for a date, according to UTC.
getUTCSeconds :: JSDate -> Number
getUTCSeconds dt = runFn2 dateMethod "getUTCSeconds" dt

-- | Returns the day of the month for a date, according to the current
-- | machine's date/time locale.
getDate :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDate dt = runFn2 dateMethodEff "getDate" dt

-- | Returns the day of the week for a date, according to the current
-- | machine's date/time locale.
getDay :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDay dt = runFn2 dateMethodEff "getDay" dt

-- | Returns the year for a date, according to the current machine's date/time
-- | locale.
getFullYear :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getFullYear dt = runFn2 dateMethodEff "getFullYear" dt

-- | Returns the hour for a date, according to the current machine's date/time
-- | locale.
getHours :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getHours dt = runFn2 dateMethodEff "getHours" dt

-- | Returns the milliseconds for a date, according to the current machine's
-- | date/time locale.
getMilliseconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMilliseconds dt = runFn2 dateMethodEff "getMilliseconds" dt

-- | Returns the minutes for a date, according to the current machine's
-- | date/time locale.
getMinutes :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMinutes dt = runFn2 dateMethodEff "getMinutes" dt

-- | Returns the month for a date, according to the current machine's
-- | date/time locale.
getMonth :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMonth dt = runFn2 dateMethodEff "getMonth" dt

-- | Returns the seconds for a date, according to the current machine's
-- | date/time locale.
getSeconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getSeconds dt = runFn2 dateMethodEff "getSeconds" dt

-- | Returns the time-zone offset for a date, according to the current machine's
-- | date/time locale.
getTimezoneOffset :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getTimezoneOffset dt = runFn2 dateMethodEff "getTimezoneOffset" dt

-- | Returns the date portion of a date value as a human-readable string.
toDateString :: JSDate -> String
toDateString dt = runFn2 dateMethod "toDateString" dt

-- | Converts a date value to an ISO 8601 Extended format date string.
toISOString :: forall eff. JSDate -> Eff (err :: EXCEPTION | eff) String
toISOString dt = runFn2 dateMethodEff "toISOString" dt

-- | Returns a string representing for a date value.
toString :: JSDate -> String
toString dt = runFn2 dateMethod "toString" dt

-- | Returns the time portion of a date value as a human-readable string.
toTimeString :: JSDate -> String
toTimeString dt = runFn2 dateMethod "toTimeString" dt

-- | Returns the date as a string using the UTC timezone.
toUTCString :: JSDate -> String
toUTCString dt = runFn2 dateMethod "toUTCString" dt

-- | A module providing a type and operations for the native JavaScript `Date`
-- | object.
-- |
-- | The `JSDate` type and associated functions are provided for interop
-- | purposes with JavaScript, but for working with dates in PureScript it is
-- | recommended that `DateTime` representation is used instead - `DateTime`
-- | offers greater type safety, a more PureScript-friendly interface, and has
-- | a `Generic` instance.
module Data.JSDate where

import Prelude

import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Exception (EXCEPTION)

import Data.Date as Date
import Data.DateTime (DateTime(..), Date)
import Data.DateTime as DateTime
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Enum (fromEnum)
import Data.Foreign (F, Foreign, unsafeReadTagged)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Data.Time as Time
import Data.Time.Duration (Milliseconds(..))

-- | The type of JavaScript `Date` objects.
foreign import data JSDate :: Type

readDate :: Foreign -> F JSDate
readDate = unsafeReadTagged "Date"

-- | Checks whether a date value is valid. When a date is invalid, the majority
-- | of the functions return `NaN`, `"Invalid Date"`, or throw an exception.
foreign import isValid :: JSDate -> Boolean

-- | Converts a `DateTime` value into a native JavaScript date object. The
-- | resulting date value is guaranteed to be valid.
fromDateTime :: DateTime -> JSDate
fromDateTime (DateTime d t) = jsdate
  { year: toNumber (fromEnum (Date.year d))
  , month: toNumber (fromEnum (Date.month d) - 1)
  , day: toNumber (fromEnum (Date.day d))
  , hour: toNumber (fromEnum (Time.hour t))
  , minute: toNumber (fromEnum (Time.minute t))
  , second: toNumber (fromEnum (Time.second t))
  , millisecond: toNumber (fromEnum (Time.millisecond t))
  }

-- | Attempts to construct a `DateTime` value for a `JSDate`. `Nothing` is
-- | returned only when the date value is an invalid date.
toDateTime :: JSDate -> Maybe DateTime
toDateTime = map Instant.toDateTime <$> toInstant

-- | Attempts to construct a `Date` value for a `JSDate`, ignoring any time
-- | component of the `JSDate`. `Nothing` is returned only when the date value
-- | is an invalid date.
toDate :: JSDate -> Maybe Date
toDate = map DateTime.date <$> toDateTime

-- | Attempts to construct an `Instant` for a `JSDate`. `Nothing` is returned
-- | only when the date value is an invalid date.
toInstant :: JSDate -> Maybe Instant
toInstant = Instant.instant <<< Milliseconds <=< toInstantImpl Just Nothing

foreign import toInstantImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> JSDate
  -> Maybe Number

-- | Constructs a new `JSDate` from UTC component values. If any of the values
-- | are `NaN` the resulting date will be invalid.
foreign import jsdate
  :: { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> JSDate

-- | Constructs a new `JSDate` from component values using the current machine's
-- | locale. If any of the values are `NaN` the resulting date will be invalid.
foreign import jsdateLocal
  :: forall eff
   . { year :: Number
     , month :: Number
     , day :: Number
     , hour :: Number
     , minute :: Number
     , second :: Number
     , millisecond :: Number
     }
  -> Eff (locale :: LOCALE | eff) JSDate

foreign import dateMethodEff :: forall eff a. Fn2 String JSDate (Eff eff a)
foreign import dateMethod :: forall a. Fn2 String JSDate a

-- | Attempts to parse a date from a string. The behaviour of this function is
-- | implementation specific until ES5, so may not always have the same
-- | behaviour for a given string. The RFC2822 and ISO8601 date string formats
-- | should parse consistently.
-- |
-- | The `LOCALE` effect is present here as if no time zone is specified in the
-- | string the current locale's time zone will be used instead.
foreign import parse
  :: forall eff. String -> Eff (locale :: LOCALE | eff) JSDate

-- | The effect type used when indicating the current machine's date/time locale
-- | is used in computing a value.
foreign import data LOCALE :: Effect

-- | Returns the date as a number of milliseconds since 1970-01-01 00:00:00 UTC.
getTime :: JSDate -> Number
getTime dt = runFn2 dateMethod "getTime" dt

-- | Returns the day of the month for a date, according to UTC.
getUTCDate :: JSDate -> Number
getUTCDate dt = runFn2 dateMethod "getUTCDate" dt

-- | Returns the day of the week for a date, according to UTC.
getUTCDay :: JSDate -> Number
getUTCDay dt = runFn2 dateMethod "getUTCDay" dt

-- | Returns the year for a date, according to UTC.
getUTCFullYear :: JSDate -> Number
getUTCFullYear dt = runFn2 dateMethod "getUTCFullYear" dt

-- | Returns the hours for a date, according to UTC.
getUTCHours :: JSDate -> Number
getUTCHours dt = runFn2 dateMethod "getUTCHours" dt

-- | Returns the milliseconds for a date, according to UTC.
getUTCMilliseconds :: JSDate -> Number
getUTCMilliseconds dt = runFn2 dateMethod "getUTCMilliseconds" dt

-- | Returns the minutes for a date, according to UTC.
getUTCMinutes :: JSDate -> Number
getUTCMinutes dt = runFn2 dateMethod "getUTCMinutes" dt

-- | Returns the month for a date, according to UTC.
getUTCMonth :: JSDate -> Number
getUTCMonth dt = runFn2 dateMethod "getUTCMonth" dt

-- | Returns the seconds for a date, according to UTC.
getUTCSeconds :: JSDate -> Number
getUTCSeconds dt = runFn2 dateMethod "getUTCSeconds" dt

-- | Returns the day of the month for a date, according to the current
-- | machine's date/time locale.
getDate :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDate dt = runFn2 dateMethodEff "getDate" dt

-- | Returns the day of the week for a date, according to the current
-- | machine's date/time locale.
getDay :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getDay dt = runFn2 dateMethodEff "getDay" dt

-- | Returns the year for a date, according to the current machine's date/time
-- | locale.
getFullYear :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getFullYear dt = runFn2 dateMethodEff "getFullYear" dt

-- | Returns the hour for a date, according to the current machine's date/time
-- | locale.
getHours :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getHours dt = runFn2 dateMethodEff "getHours" dt

-- | Returns the milliseconds for a date, according to the current machine's
-- | date/time locale.
getMilliseconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMilliseconds dt = runFn2 dateMethodEff "getMilliseconds" dt

-- | Returns the minutes for a date, according to the current machine's
-- | date/time locale.
getMinutes :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMinutes dt = runFn2 dateMethodEff "getMinutes" dt

-- | Returns the month for a date, according to the current machine's
-- | date/time locale.
getMonth :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getMonth dt = runFn2 dateMethodEff "getMonth" dt

-- | Returns the seconds for a date, according to the current machine's
-- | date/time locale.
getSeconds :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getSeconds dt = runFn2 dateMethodEff "getSeconds" dt

-- | Returns the time-zone offset for a date, according to the current machine's
-- | date/time locale.
getTimezoneOffset :: forall eff. JSDate -> Eff (locale :: LOCALE | eff) Number
getTimezoneOffset dt = runFn2 dateMethodEff "getTimezoneOffset" dt

-- | Returns the date portion of a date value as a human-readable string.
toDateString :: JSDate -> String
toDateString dt = runFn2 dateMethod "toDateString" dt

-- | Converts a date value to an ISO 8601 Extended format date string.
toISOString :: forall eff. JSDate -> Eff (err :: EXCEPTION | eff) String
toISOString dt = runFn2 dateMethodEff "toISOString" dt

-- | Returns a string representing for a date value.
toString :: JSDate -> String
toString dt = runFn2 dateMethod "toString" dt

-- | Returns the time portion of a date value as a human-readable string.
toTimeString :: JSDate -> String
toTimeString dt = runFn2 dateMethod "toTimeString" dt

-- | Returns the date as a string using the UTC timezone.
toUTCString :: JSDate -> String
toUTCString dt = runFn2 dateMethod "toUTCString" dt