bugfix: Display correct operator types

bugfix: Display correct operator types

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.JQuery as J
import DOM (DOM)

import AST (TypeTree, Tree(..), Binding(..), TypedBinding, Type(..), Atom(..), Op, pPrintOp, TypeQual, QualTree(..), MType, prettyPrintType)

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 MType

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

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

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

    go hole expr@(App t func args) = app t (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing 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 "<-" ["comma"] []

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

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 t) = typedNode (pPrintOp op) ["op"] [] t

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"] []
    close = node "]" ["brace"] []
    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"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom t a] t
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) t
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) t
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) t

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

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM | eff) J.JQuery
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["expand"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM | eff) Unit
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"] classes then false else true

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv
  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

  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 | 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.JQuery as J
import DOM (DOM)

import AST (TypeTree, Tree(..), Binding(..), TypedBinding, Type(..), Atom(..), Op, pPrintOp, TypeQual, QualTree(..), MType, prettyPrintType)

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

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 t a)            = atom t a
    go hole expr@(List t ls)           = case toString ls of
                                           Nothing  -> list t (zipList go (hole <<< List Nothing) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] t
    go hole expr@(NTuple t ls)         = ntuple t (zipList go (hole <<< NTuple Nothing) ls) expr hole
    go hole expr@(Binary _ op_tup@(Tuple op t) e1 e2)   = binary t op
                                           (go (\e1 -> hole $ Binary Nothing op_tup e1 e2) e1)
                                           (go (\e2 -> hole $ Binary Nothing op_tup e1 e2) e2)
                                           expr hole
    go hole expr@(Unary t op e)        = unary t (unpackOp op) (go (hole <<< Unary Nothing op) e) expr hole
    go hole expr@(SectL t e op)        = sectl t (go (\e -> hole $ SectL Nothing e op) e) (unpackOp op) expr hole
    go hole expr@(SectR t op e)        = sectr t (unpackOp op) (go (hole <<< SectR Nothing op) e) expr hole
    go hole      (PrefixOp t op)       = prefixOp t (unpackOp op)
    go hole expr@(IfExpr t ce te ee)   = ifexpr t
                                           (go (\ce -> hole $ IfExpr Nothing ce te ee) ce)
                                           (go (\te -> hole $ IfExpr Nothing ce te ee) te)
                                           (go (\ee -> hole $ IfExpr Nothing ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr t bes body)  = letexpr t
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr Nothing xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr Nothing bes x) body)
                                           expr hole
    go hole expr@(Lambda t binds body) = lambda t (binding <$> binds) (go (hole <<< Lambda Nothing binds) body) expr hole

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

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

    go hole expr@(App t func args) = app t (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App Nothing func args
        argsDivs = zipList go (hole <<< App Nothing 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 "<-" ["comma"] []

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

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 :: Tuple Op MType -> Op
unpackOp (Tuple op _) = op

opToDiv :: MType -> Op -> Div
opToDiv t op = typedNode (pPrintOp op) ["op"] [] t

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

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

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

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

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

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

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

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"] []
    close = node "]" ["brace"] []
    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"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots"] []
    end       = fromMaybe mend
    close     = node "]" ["brace"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom t a] t
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) t
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) t
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) t

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

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM | eff) J.JQuery
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["expand"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM | eff) Unit
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 (TypCon _) = false
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding"] classes then false else true

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv
  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

  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 | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

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


Call matcher when initial

Call matcher when initial

module Cherry
  ( BED
  , Config(..)
  , AppEffects
  , Tree
  , View
  , Subscription
  , app
  , select
  , reduce
  , router
  , navigateTo
  , redirectTo
  , goForward
  , goBack
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (newRef, readRef, modifyRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Data.Foldable (sequence_)
import Data.Foreign.Null (writeNull)
import Data.List (List(..), (!!), (:))
import Data.Maybe (maybe)
import Data.Nullable (toMaybe)
import Data.VirtualDOM (VNode, patch)
import Data.VirtualDOM.DOM (api)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event, EventType, EventTarget)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (popstate)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, forward, back)
import DOM.HTML.Location (pathname, search)
import DOM.HTML.Types (Window, HISTORY, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document, location, history)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (Node, elementToNode)

foreign import data BED :: !

type AppEffects e = (console :: CONSOLE, bed :: BED, dom :: DOM, history :: HISTORY | e)

type Tree e = VNode e Node Event

type View e s = s -> Tree e

type Subscription e = Eff e Unit

newtype Config e s = Config
  { selector :: String
  , state :: s
  , view :: View e s
  , subscriptions :: Array (Subscription e)
  }

foreign import select :: forall e s. (s -> s) -> Eff (bed :: BED | e) s

foreign import reduce :: forall e s. (s -> s) -> Eff (bed :: BED | e) Unit

foreign import requestAnimationFrame :: forall e. Eff (dom :: DOM | e) Unit ->
                                        Window ->
                                        Eff (dom :: DOM | e) Unit

foreign import dispatchEvent :: forall e. EventType ->
                                Window ->
                                Eff (dom :: DOM | e) Unit

app :: forall e s. Config (AppEffects e) s -> Eff (AppEffects e) Unit
app (Config { selector, state, view, subscriptions }) = do
  reduce (\_ -> state)
  historyRef <- unsafeRunRef $ newRef Nil
  sequence_ subscriptions
  draw $ render historyRef
    where
      container =
        let doc = htmlDocumentToParentNode <$> (window >>= document)
        in map elementToNode <<< toMaybe <$> (doc >>= querySelector selector)

      warn = log $ selector <> "is not found."

      patch' prev next target = patch api target prev next

      render historyRef = do
        target <- container
        currentState <- select (\s -> s)
        history <- unsafeRunRef do
          modifyRef historyRef (\h -> (view currentState) : h)
          readRef historyRef
        maybe warn (patch' (history !! 1) (history !! 0)) target

      draw renderer = do
        renderer
        window >>= requestAnimationFrame (draw renderer)

router :: forall e. (String -> Eff (dom :: DOM | e) Unit) ->
          Eff (dom :: DOM | e) Unit
router matcher = do
  handler
  eventWindow >>= addEventListener popstate listener false
    where
      path = do
        l <- window >>= location
        (<>) <$> pathname l <*> search l
      handler = path >>= matcher
      listener = eventListener (\_ -> handler)

navigateTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
navigateTo url = do
  window >>= history >>= pushState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

redirectTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
redirectTo url = do
  window >>= history >>= replaceState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

goForward :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goForward = window >>= history >>= forward

goBack :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goBack = window >>= history >>= back

eventWindow :: forall e. Eff (dom :: DOM | e) EventTarget
eventWindow = windowToEventTarget <$> window

module Cherry
  ( BED
  , Config(..)
  , AppEffects
  , Tree
  , View
  , Subscription
  , app
  , select
  , reduce
  , router
  , navigateTo
  , redirectTo
  , goForward
  , goBack
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ref (newRef, readRef, modifyRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Data.Foldable (sequence_)
import Data.Foreign.Null (writeNull)
import Data.List (List(..), (!!), (:))
import Data.Maybe (maybe)
import Data.Nullable (toMaybe)
import Data.VirtualDOM (VNode, patch)
import Data.VirtualDOM.DOM (api)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event, EventType, EventTarget)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (popstate)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, forward, back)
import DOM.HTML.Location (pathname, search)
import DOM.HTML.Types (Window, HISTORY, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document, location, history)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (Node, elementToNode)

foreign import data BED :: !

type AppEffects e = (console :: CONSOLE, bed :: BED, dom :: DOM, history :: HISTORY | e)

type Tree e = VNode e Node Event

type View e s = s -> Tree e

type Subscription e = Eff e Unit

newtype Config e s = Config
  { selector :: String
  , state :: s
  , view :: View e s
  , subscriptions :: Array (Subscription e)
  }

foreign import select :: forall e s. (s -> s) -> Eff (bed :: BED | e) s

foreign import reduce :: forall e s. (s -> s) -> Eff (bed :: BED | e) Unit

foreign import requestAnimationFrame :: forall e. Eff (dom :: DOM | e) Unit ->
                                        Window ->
                                        Eff (dom :: DOM | e) Unit

foreign import dispatchEvent :: forall e. EventType ->
                                Window ->
                                Eff (dom :: DOM | e) Unit

app :: forall e s. Config (AppEffects e) s -> Eff (AppEffects e) Unit
app (Config { selector, state, view, subscriptions }) = do
  reduce (\_ -> state)
  historyRef <- unsafeRunRef $ newRef Nil
  sequence_ subscriptions
  draw $ render historyRef
    where
      container =
        let doc = htmlDocumentToParentNode <$> (window >>= document)
        in map elementToNode <<< toMaybe <$> (doc >>= querySelector selector)

      warn = log $ selector <> "is not found."

      patch' prev next target = patch api target prev next

      render historyRef = do
        target <- container
        currentState <- select (\s -> s)
        history <- unsafeRunRef do
          modifyRef historyRef (\h -> (view currentState) : h)
          readRef historyRef
        maybe warn (patch' (history !! 1) (history !! 0)) target

      draw renderer = do
        renderer
        window >>= requestAnimationFrame (draw renderer)

router :: forall e. (String -> Eff (dom :: DOM | e) Unit) ->
          Eff (dom :: DOM | e) Unit
router matcher = eventWindow >>= addEventListener popstate listener false
  where
    path = do
      l <- window >>= location
      (<>) <$> pathname l <*> search l
    listener = eventListener (\_ -> path >>= matcher)

navigateTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
navigateTo url = do
  window >>= history >>= pushState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

redirectTo :: forall e. String ->
              Eff (dom :: DOM, history :: HISTORY | e) Unit
redirectTo url = do
  window >>= history >>= replaceState writeNull (DocumentTitle "") (URL url)
  window >>= dispatchEvent popstate

goForward :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goForward = window >>= history >>= forward

goBack :: forall e. Eff (dom :: DOM, history :: HISTORY | e) Unit
goBack = window >>= history >>= back

eventWindow :: forall e. Eff (dom :: DOM | e) EventTarget
eventWindow = windowToEventTarget <$> window


add index command

add index command

module Main
  ( main
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Control.Promise (Promise)
import Control.Promise as Promise
import Data.Array as Array
import Data.Either as Either
import Data.Maybe (Maybe)
import Data.Maybe as Maybe
import Effect (Effect)
import Effect.Aff as Aff
import Effect.Class.Console as Console
import Effect.Exception as Exception
import Foreign.Object as Object
import Node.Process as Process
import Record as Record

foreign import data Client :: Type
foreign import data Response :: Type
foreign import newClient ::
  { apiKey :: String
  , authType :: String -- basic or wsse
  , blogId :: String
  , hatenaId :: String
  } -> Effect Client
foreign import create ::
  forall r. { | r } -> Client -> Effect (Promise Response)
foreign import delete :: String -> Client -> Effect (Promise Response)
foreign import edit ::
  forall r. String -> { | r } -> Client -> Effect (Promise Response)
foreign import list ::
  Client ->
  Effect
    (Promise
      (Array
        { authorName :: String
        , content :: String
        , contentType :: String
        , draft :: Boolean
        , editUrl :: String
        , edited :: String
        , formattedContent :: String
        , htmlUrl :: String
        , id :: String
        , published :: String
        , summary :: String
        , title :: String
        , updated :: String
        }))
foreign import retrieve :: String -> Client -> Effect (Promise Response)

type Config =
  { apiKey :: String
  , blogId :: String
  , hatenaId :: String
  }

loadConfig :: Effect (Maybe Config)
loadConfig = do
  env <- Process.getEnv
  pure do
    apiKey <- Object.lookup "HATENA_API_KEY" env
    blogId <- Object.lookup "HATENA_BLOG_ID" env
    hatenaId <- Object.lookup "HATENA_ID" env
    pure { apiKey, blogId, hatenaId }
main :: Effect Unit
main = do
  configMaybe <- loadConfig
  config <- Maybe.maybe (Exception.throw "invalid config") pure configMaybe
  client <- newClient (Record.merge config { authType: "wsse" })
  args <- map (Array.drop 2) Process.argv
  { arguments } <-
    Either.either
      (const (Exception.throw "invalid option"))
      pure
      (CommandLineOption.parse {} args)
  command <-
    Maybe.maybe
      (Exception.throw "no command")
      pure
      (Array.index arguments 0)
  case command of
    "index" -> Aff.launchAff_ do
      response <- Promise.toAffE (list client)
      Console.logShow response -- TODO: format
    _ -> -- TODO
      Console.log command

module Main
  ( main
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Control.Promise (Promise)
import Data.Array as Array
import Data.Either as Either
import Data.Maybe as Maybe
import Effect (Effect)
import Effect.Console as Console
import Effect.Exception as Exception
import Node.Process as Process

foreign import data Client :: Type
foreign import data Response :: Type
foreign import newClient :: forall r. { | r } -> Effect Client
foreign import create ::
  forall r. { | r } -> Client -> Effect (Promise Response)
foreign import delete :: String -> Client -> Effect (Promise Response)
foreign import edit ::
  forall r. String -> { | r } -> Client -> Effect (Promise Response)
foreign import list :: Client -> Effect (Promise Response)
foreign import retrieve :: String -> Client -> Effect (Promise Response)

main :: Effect Unit
main = do
  args <- map (Array.drop 2) Process.argv
  { arguments } <-
    Either.either
      (const (Exception.throw "invalid option"))
      pure
      (CommandLineOption.parse {} args)
  command <-
    Maybe.maybe
      (Exception.throw "no command")
      pure
      (Array.index arguments 0)
  Console.log command


Add show instance for Array to prelude

Add show instance for Array to prelude

module Prelude where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

module Prelude where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]