Tidy

Tidy

Original commit a665738b26eba12431e59c59e633976f951498c2

module Doc
    ( Doc
    , Renderer
    , Transforms
    , getTopLevel
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import Prelude

import IR
import IRGraph

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Foldable (for_)
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.Tuple (Tuple(..), snd)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type Transforms =
    { nameForClass :: IRClassData -> String
    , unionName :: List String -> String
    , unionPredicate :: IRType -> Maybe (Set IRType)
    , nextName :: String -> String
    , forbiddenNames :: Array String
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map (Set IRType) String
    , unions :: List (Set IRType)
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph =
    let classes = classesInGraph graph
        forbidden = S.fromFoldable t.forbiddenNames
        classNames = transformNames t.nameForClass t.nextName forbidden classes
        unions = L.fromFoldable $ filterTypes t.unionPredicate graph
        forbiddenForUnions = S.union forbidden $ S.fromFoldable $ M.values classNames
        nameForUnion s = t.unionName $ map (typeNameForUnion graph) $ L.sort $ L.fromFoldable s
        unionNames = transformNames nameForUnion t.nextName forbiddenForUnions $ map (\s -> Tuple s s) unions
    in
        evalRWS w { graph, classNames, unionNames, unions } { indent: 0 } # snd

typeNameForUnion :: IRGraph -> IRType -> String
typeNameForUnion graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion graph t <> "_map"
    IRUnion _ -> "union"

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  pure $ typeNameForUnion g typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevel :: Doc IRType
getTopLevel = do
    IRGraph { toplevel } <- getGraph
    pure toplevel

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List (Set IRType))
getUnions = Doc (asks _.unions)

getUnionNames :: Doc (Map (Set IRType) String)
getUnionNames = Doc (asks _.unionNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = classesInGraph <$> getGraph

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = times "\t" indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

-- Cannot make this work any other way!
times :: String -> Int -> String
times s n | n < 1 = ""
times s 1 = s
times s n = s <> times s (n - 1)

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

module Doc
    ( Doc
    , Renderer
    , Transforms
    , getTopLevel
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Foldable (for_, intercalate, sequence_)
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.Tuple (Tuple(..), snd)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type Transforms =
    { nameForClass :: IRClassData -> String
    , unionName :: List String -> String
    , unionPredicate :: IRType -> Maybe (Set IRType)
    , nextName :: String -> String
    , forbiddenNames :: Array String
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map (Set IRType) String
    , unions :: List (Set IRType)
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph =
    let classes = classesInGraph graph
        forbidden = S.fromFoldable t.forbiddenNames
        classNames = transformNames t.nameForClass t.nextName forbidden classes
        unions = L.fromFoldable $ filterTypes t.unionPredicate graph
        forbiddenForUnions = S.union forbidden $ S.fromFoldable $ M.values classNames
        nameForUnion s = t.unionName $ map (typeNameForUnion graph) $ L.sort $ L.fromFoldable s
        unionNames = transformNames nameForUnion t.nextName forbiddenForUnions $ map (\s -> Tuple s s) unions
    in
        evalRWS w { graph, classNames, unionNames, unions } { indent: 0 } # snd

typeNameForUnion :: IRGraph -> IRType -> String
typeNameForUnion graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion graph t <> "_map"
    IRUnion _ -> "union"

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  pure $ typeNameForUnion g typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevel :: Doc IRType
getTopLevel = do
    IRGraph { toplevel } <- getGraph
    pure toplevel

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List (Set IRType))
getUnions = Doc (asks _.unions)

getUnionNames :: Doc (Map (Set IRType) String)
getUnionNames = Doc (asks _.unionNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = classesInGraph <$> getGraph

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = times "\t" indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

-- Cannot make this work any other way!
times :: String -> Int -> String
times s n | n < 1 = ""
times s 1 = s
times s n = s <> times s (n - 1)

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a


implemented web stuff

implemented web stuff

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 (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError)

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
atom t (Constr n) = typedNode n ["atom", "constr"] [] 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
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name len ps -> typedNode "" ["binding", "constrLit"] (listify "" " " "" (binding <$> ps)) t
  -- TODO: "node op [] []"
  InfixDataConstr op a p l r -> typedNode "" ["binding", "infixConstrLit"] [binding l, node op [] [], binding r] 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 (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 | 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 | 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

  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 (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding,
            Type(..), TypeQual, pPrintOp, prettyPrintType, prettyPrintTypeError)

import JSHelpers (unsafeUndef)

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
atom t (Constr n) = unsafeUndef "atom t (Constr n)"

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
-- TODO
binding (ConstrLit _ _) = unsafeUndef "binding (ConstrLit _ _)"

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 (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 | 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 | 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

  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


clearRect

clearRect

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | ClearRect         C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a) = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a) = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a) = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a) = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a) = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a) = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a) = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a) = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a) = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a) = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a) = const a <$> C.beginPath ctx
  interp (Stroke a) = const a <$> C.stroke ctx
  interp (Fill a) = const a <$> C.fill ctx
  interp (Clip a) = const a <$> C.clip ctx
  interp (LineTo x y a) = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a) = const a <$> C.moveTo ctx x y
  interp (ClosePath a) = const a <$> C.closePath ctx
  interp (Arc arc a) = const a <$> C.arc ctx arc
  interp (Rect r a) = const a <$> C.rect ctx r
  interp (ClearRect r a) = const a <$> C.clearRect ctx r
  interp (Scale sx sy a) = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a) = const a <$> C.rotate th ctx
  interp (Translate tx ty a) = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a) = const a <$> C.transform tx ctx
  interp (SetFont f a) = const a <$> C.setFont f ctx
  interp (FillText s x y a) = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a) = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k) = k <$> C.measureText ctx s
  interp (Save a) = const a <$> C.save ctx
  interp (Restore a) = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a) = const a <$> C.putImageData ctx d x y

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect

  , scale
  , rotate
  , translate
  , transform

  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth      Number      more
  | SetFillStyle      String      more
  | SetStrokeStyle    String      more
  | SetShadowColor    String      more
  | SetShadowBlur     Number      more
  | SetShadowOffsetX  Number      more
  | SetShadowOffsetY  Number      more
  | SetLineCap        C.LineCap   more
  | SetComposite      C.Composite more
  | SetAlpha          Number      more
  | BeginPath         more
  | Stroke            more
  | Fill              more
  | Clip              more
  | LineTo            Number      Number      more
  | MoveTo            Number      Number      more
  | ClosePath         more
  | Arc               C.Arc       more
  | Rect              C.Rectangle more
  | Scale             Number      Number      more
  | Rotate            Number      more
  | Translate         Number      Number      more
  | Transform         C.Transform more
  | SetFont           String      more
  | FillText          String      Number      Number    more
  | StrokeText        String      Number      Number    more
  | MeasureText       String      (C.TextMetrics -> more)
  | Save              more
  | Restore           more
  | GetImageData      Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData      C.ImageData Number      Number    more

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a) = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a) = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a) = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a) = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a) = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a) = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a) = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a) = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a) = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a) = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a) = const a <$> C.beginPath ctx
  interp (Stroke a) = const a <$> C.stroke ctx
  interp (Fill a) = const a <$> C.fill ctx
  interp (Clip a) = const a <$> C.clip ctx
  interp (LineTo x y a) = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a) = const a <$> C.moveTo ctx x y
  interp (ClosePath a) = const a <$> C.closePath ctx
  interp (Arc arc a) = const a <$> C.arc ctx arc
  interp (Rect r a) = const a <$> C.rect ctx r
  interp (Scale sx sy a) = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a) = const a <$> C.rotate th ctx
  interp (Translate tx ty a) = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a) = const a <$> C.transform tx ctx
  interp (SetFont f a) = const a <$> C.setFont f ctx
  interp (FillText s x y a) = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a) = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k) = k <$> C.measureText ctx s
  interp (Save a) = const a <$> C.save ctx
  interp (Restore a) = const a <$> C.restore ctx
  interp (GetImageData x y w h k) = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a) = const a <$> C.putImageData ctx d x y


Added shouldNotContain assertion for parallelism with Equality negation.

module Test.Spec.Assertions
  ( fail
  , shouldEqual
  , shouldNotEqual
  , shouldContain
  , shouldNotContain
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class   (throwError)
import Data.Foldable               (class Foldable, notElem, elem)

fail :: forall r. String -> Aff r Unit
fail msg = throwError $ error $ msg

shouldEqual :: forall r t. Show t => Eq t => t -> t -> Aff r Unit
shouldEqual v1 v2 =
  when (v1 /= v2) $
    fail $ show v1 <> " ≠ " <> show v2

shouldNotEqual :: forall r t. Show t => Eq t => t -> t -> Aff r Unit
shouldNotEqual v1 v2 =
  when (v1 == v2) $
    fail $ show v1 <> " = " <> show v2

shouldContain :: forall r f a. Show a => Eq a => Show (f a) => Foldable f => f a -> a -> Aff r Unit
shouldContain c e =
  when (e `notElem` c) $
    fail $ (show e) <> " ∉ " <> (show c)

shouldNotContain :: forall r f a. Show a => Eq a => Show (f a) => Foldable f => f a -> a -> Aff r Unit
shouldNotContain c e =
  when (e `elem` c) $
    fail $ (show e) <> " ∈ " <> (show c)

module Test.Spec.Assertions
  ( fail
  , shouldEqual
  , shouldNotEqual
  , shouldContain
  ) where

import Prelude

import Control.Monad.Aff           (Aff())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class   (throwError)
import Data.Foldable               (class Foldable, notElem)

fail :: forall r. String -> Aff r Unit
fail msg = throwError $ error $ msg

shouldEqual :: forall r t. Show t => Eq t => t -> t -> Aff r Unit
shouldEqual v1 v2 =
  when (v1 /= v2) $
    fail $ show v1 <> " ≠ " <> show v2

shouldNotEqual :: forall r t. Show t => Eq t => t -> t -> Aff r Unit
shouldNotEqual v1 v2 =
  when (v1 == v2) $
    fail $ show v1 <> " = " <> show v2

shouldContain :: forall r f a. Show a => Eq a => Show (f a) => Foldable f => f a -> a -> Aff r Unit
shouldContain c e =
  when (e `notElem` c) $
    fail $ (show e) <> " ∉ " <> (show c)


Update colours

Update colours

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Attribute, Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

pitColor :: PitState -> Color
pitColor (Just Turn.Capture) = hsl 300.0 1.0 0.3
pitColor (Just Turn.Lift) = hsl 150.0 1.0 0.3
pitColor (Just Turn.Sow) = lighten 0.3 $ pitColor Nothing
pitColor _ = hsl 70.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewHandRow A
  , viewRow A
  , viewRow B
  , viewHandRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewHandRow player =
      div [css] $ FM.mapRowWithIndex player (\ref pit -> viewHandInPit state ref) board.cells
    viewRow player =
      div [css] $ FM.mapRowWithIndex player (viewPit state) board.cells
    css = style $ do
            apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = numberPadded 0

viewPitEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewPitEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ cellStyle color

numberPadded :: Int -> String
numberPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

cellStyle :: forall a. Color -> Attribute a
cellStyle color = style do
    C.display C.inline
    C.fontSize (em 2.0)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5

viewHandInPit :: forall action state. BoardView state action
              => state -> PitRef -> Html action
viewHandInPit state ref =
  H.pre [cellStyle color] [ text s ]
    where color = C.white
          s = fromMaybe (viewPlayerEmoji Nothing) do
                hand <- getHand state
                if hand.pitRef == ref
                  then pure $ (viewPlayerEmoji $ Just hand.player) <> show hand.seeds
                  else Nothing

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Attribute, Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewHandRow A
  , viewRow A
  , viewRow B
  , viewHandRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewHandRow player =
      div [css] $ FM.mapRowWithIndex player (\ref pit -> viewHandInPit state ref) board.cells
    viewRow player =
      div [css] $ FM.mapRowWithIndex player (viewPit state) board.cells
    css = style $ do
            apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = numberPadded 0

viewPitEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewPitEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewPit :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ cellStyle color

numberPadded :: Int -> String
numberPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

cellStyle :: forall a. Color -> Attribute a
cellStyle color = style do
    C.display C.inline
    C.fontSize (em 2.0)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5

viewHandInPit :: forall action state. BoardView state action
              => state -> PitRef -> Html action
viewHandInPit state ref =
  H.pre [cellStyle color] [ text s ]
    where color = C.white
          s = fromMaybe (viewPlayerEmoji Nothing) do
                hand <- getHand state
                if hand.pitRef == ref
                  then pure $ (viewPlayerEmoji $ Just hand.player) <> show hand.seeds
                  else Nothing

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a


Increased movement rate to 1 m/s.

Increased movement rate to 1 m/s.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | The rate equation!
applyRate :: Number -> Seconds -> Number
applyRate v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 1.0

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * applyRate angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (applyRate movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | The rate equation!
applyRate :: Number -> Seconds -> Number
applyRate v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * applyRate angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (applyRate movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


Add Testable instance for Gen`

Add Testable instance for Gen`

module Test.StrongCheck
  ( SC(..)
  , Result(..)
  , class Testable, test
  , quickCheck
  , quickCheck'
  , quickCheckWithSeed
  , quickCheckPure
  , smallCheck
  , smallCheckPure
  , statCheck
  , statCheckPure
  , assert
  , assertEq, (===)
  , assertNotEq, (/==)
  , annotate, (<?>)
  , module Exports
  )
  where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Free (Free)
import Control.Monad.Trampoline (runTrampoline)

import Data.Array as A
import Data.Foldable (class Foldable)
import Data.Int as Int
import Data.Lazy (Lazy)
import Data.List (List(..), length)
import Data.List as List
import Data.Maybe (maybe)
import Data.Monoid (class Monoid)
import Data.Tuple (Tuple(..))

import Math as Math

import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.StrongCheck.Gen (GenT, Gen, GenState(..), collectAll, sample', decorateSeed)
import Test.StrongCheck.LCG (Seed, randomSeed, runSeed)

import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary) as Exports
import Test.StrongCheck.LCG (Seed, mkSeed) as Exports

-- | A type synonym for StrongCheck effects in Eff.
type SC eff a = Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) a

-- | The result of a property test.
data Result = Success | Failed String

derive instance eqResult :: Eq Result
derive instance ordResult :: Ord Result

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " <> msg

instance semigroupResult :: Semigroup Result where
  append Success Success = Success
  append (Failed msg) Success = Failed msg
  append Success (Failed msg) = Failed msg
  append (Failed m1) (Failed m2) = Failed (m1 <> "\n" <> m2)

instance monoidResult :: Monoid Result where
  mempty = Success

-- | A class for types that can be treated as a property test result.
class Testable prop where
  test :: prop -> Gen Result

instance testableBoolean :: Testable Boolean where
  test true = pure Success
  test false = pure $ Failed "Test returned false"

instance testableResult :: Testable Result where
  test = pure

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = test <<< f =<< arbitrary

instance testableGen :: Testable prop => Testable (GenT (Free Lazy) prop) where
  test = flip bind test

-- | Checks the proposition for 100 random values.
quickCheck :: forall eff prop. Testable prop => prop -> SC eff Unit
quickCheck prop = quickCheck' 100 prop

-- | Checks the proposition for the specified number of random values.
quickCheck' :: forall eff prop. Testable prop => Int -> prop -> SC eff Unit
quickCheck' n prop = do
  seed <- randomSeed
  quickCheckWithSeed seed n prop

-- | Checks the proposition for the specified number of random values, starting with a specific seed.
quickCheckWithSeed :: forall eff prop. Testable prop => Seed -> Int -> prop -> SC eff Unit
quickCheckWithSeed seed n prop = check (quickCheckPure n seed) prop

-- | Checks the proposition for the specified number of random values in a pure
-- | setting, returning an array of results.
quickCheckPure :: forall prop. Testable prop => Int -> Seed -> prop -> Array (Tuple Seed Result)
quickCheckPure n s prop = runTrampoline $ sample' n (defState s) (decorateSeed (test prop))

-- | Exhaustively checks the proposition for all possible values. Assumes the
-- | generator is a finite generator.
smallCheck :: forall eff prop. Testable prop => prop -> SC eff Unit
smallCheck prop = do
  seed <- randomSeed
  check (smallCheckPure seed) prop

-- | Exhaustively checks the proposition for all possible values in a pure
-- | setting, returning an array of results. Assumes the generator is a finite
-- | generator.
smallCheckPure :: forall prop. Testable prop => Seed -> prop -> Array (Tuple Seed Result)
smallCheckPure s prop = runTrampoline $ collectAll (defState s) (decorateSeed (test prop))

-- | Checks that the proposition has a certain probability of being true for
-- | arbitrary values.
statCheck :: forall eff prop. Testable prop => Number -> prop -> SC eff Unit
statCheck freq prop = do
  seed <- randomSeed
  log <<< show $ statCheckPure seed freq prop

-- | Checks that the proposition has a certain probability of being true for
-- | arbitrary values in a pure setting, returning a result.
statCheckPure :: forall prop. Testable prop => Seed -> Number -> prop -> Result
statCheckPure s freq prop = try 100
  where
  try :: Int -> Result
  try x =
    let
      measure :: Int -> Number
      measure n =
        let results = quickCheckPure n s prop
        in Int.toNumber $ (countSuccesses results) / (A.length results)

      measure' :: Int -> Array Number
      measure' 0 = []
      measure' n = measure' (n - 1) <> [measure (n * x)]

      freqs :: Array Number
      freqs = measure' 4

      dists :: Array Number
      dists = (Math.abs <<< (-) freq) <$> freqs

      dirs :: Array Number
      dirs  = A.zipWith (\a b -> a - b) ([1.0] <> dists) dists

      fails :: Int
      fails = A.length $ A.filter ((>) 0.0) dirs

      succs :: Array Number
      succs = A.filter ((<=) 0.0) dirs
    in
      if fails > 1
      then
        if x < 1000000 then try (x * 10)
        else Failed $ "Divergence of statistical test: freqs = " <> show freqs <> ", dists = " <> show dists <> ", dirs = " <> show dirs <> ", fails: " <> show fails
      else maybe (Failed "Error!") (\l -> if l > 0.5 then Failed $ "Final convergence distance too low: " <> show l else Success) (A.last succs)

defState :: Seed -> GenState
defState s = (GenState {seed: s, size: 10})

check :: forall eff prop f. (Testable prop, Foldable f) => (prop -> f (Tuple Seed Result)) -> prop -> SC eff Unit
check f prop = do
  let results = f prop
  let successes = countSuccesses results
  log $ show successes <> "/" <> show (length $ List.fromFoldable results) <> " test(s) passed."
  throwOnFirstFailure 1 results

throwOnFirstFailure :: forall eff f. Foldable f => Int -> f (Tuple Seed Result) -> SC eff Unit
throwOnFirstFailure n fr = throwOnFirstFailure' n (List.fromFoldable fr)
  where
  throwOnFirstFailure' :: Int -> List (Tuple Seed Result) -> SC eff Unit
  throwOnFirstFailure' _ Nil = pure unit
  throwOnFirstFailure' n' (Cons (Tuple seed (Failed msg)) _) = throwException $ error $ "Test " <> show n' <> " (seed " <> show (runSeed seed) <> ") failed: \n" <> msg
  throwOnFirstFailure' n' (Cons _ rest) = throwOnFirstFailure (n' + 1) rest

countSuccesses :: forall f. Foldable f => f (Tuple Seed Result) -> Int
countSuccesses fa = countSuccesses' 0 (List.fromFoldable fa)
  where
  countSuccesses' acc Nil = acc
  countSuccesses' acc (Cons (Tuple _ Success) rest) = countSuccesses' (acc + 1) rest
  countSuccesses' acc (Cons _ rest) = countSuccesses' acc rest

-- | Checks that the specified proposition holds. Useful for unit tests.
assert :: forall eff prop. Testable prop => prop -> SC eff Unit
assert = quickCheck' 1

-- | Converts a `Boolean` into a `Result` by lifting a message into `Failed`
-- | when the boolean is `false`.
annotate :: Boolean -> String -> Result
annotate true = const Success
annotate false = Failed

infix 1 annotate as <?>

-- | Asserts that two values are equal, resulting in a `Failure` if they are
-- | not, with a message showing the values involved.
assertEq :: forall a. (Eq a, Show a) => a -> a -> Result
assertEq a b = a == b <?> msg
  where
  msg = show a <> " /= " <> show b

infix 2 assertEq as ===

-- | Asserts that two values are not equal, resulting in a `Failure` if they
-- | are, with a message showing the values involved.
assertNotEq :: forall a. (Eq a, Show a) => a -> a -> Result
assertNotEq a b = a /= b <?> msg
  where
  msg = show a <> " == " <> show b

infix 2 assertNotEq as /==

module Test.StrongCheck
  ( SC(..)
  , Result(..)
  , class Testable, test
  , quickCheck
  , quickCheck'
  , quickCheckWithSeed
  , quickCheckPure
  , smallCheck
  , smallCheckPure
  , statCheck
  , statCheckPure
  , assert
  , assertEq, (===)
  , assertNotEq, (/==)
  , annotate, (<?>)
  , module Exports
  )
  where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Trampoline (runTrampoline)

import Data.Array as A
import Data.Foldable (class Foldable)
import Data.Int as Int
import Data.List (List(..), length)
import Data.List as List
import Data.Maybe (maybe)
import Data.Monoid (class Monoid)
import Data.Tuple (Tuple(..))

import Math as Math

import Test.StrongCheck.Gen (Gen, GenState(..), collectAll, sample', decorateSeed)
import Test.StrongCheck.LCG (Seed, randomSeed, runSeed)
import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)

import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary) as Exports
import Test.StrongCheck.LCG (Seed, mkSeed) as Exports

-- | A type synonym for StrongCheck effects in Eff.
type SC eff a = Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) a

-- | The result of a property test.
data Result = Success | Failed String

derive instance eqResult :: Eq Result
derive instance ordResult :: Ord Result

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " <> msg

instance semigroupResult :: Semigroup Result where
  append Success Success = Success
  append (Failed msg) Success = Failed msg
  append Success (Failed msg) = Failed msg
  append (Failed m1) (Failed m2) = Failed (m1 <> "\n" <> m2)

instance monoidResult :: Monoid Result where
  mempty = Success

-- | A class for types that can be treated as a property test result.
class Testable prop where
  test :: prop -> Gen Result

instance testableBoolean :: Testable Boolean where
  test true = pure Success
  test false = pure $ Failed "Test returned false"

instance testableResult :: Testable Result where
  test = pure

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = test <<< f =<< arbitrary

-- | Checks the proposition for 100 random values.
quickCheck :: forall eff prop. Testable prop => prop -> SC eff Unit
quickCheck prop = quickCheck' 100 prop

-- | Checks the proposition for the specified number of random values.
quickCheck' :: forall eff prop. Testable prop => Int -> prop -> SC eff Unit
quickCheck' n prop = do
  seed <- randomSeed
  quickCheckWithSeed seed n prop

-- | Checks the proposition for the specified number of random values, starting with a specific seed.
quickCheckWithSeed :: forall eff prop. Testable prop => Seed -> Int -> prop -> SC eff Unit
quickCheckWithSeed seed n prop = check (quickCheckPure n seed) prop

-- | Checks the proposition for the specified number of random values in a pure
-- | setting, returning an array of results.
quickCheckPure :: forall prop. Testable prop => Int -> Seed -> prop -> Array (Tuple Seed Result)
quickCheckPure n s prop = runTrampoline $ sample' n (defState s) (decorateSeed (test prop))

-- | Exhaustively checks the proposition for all possible values. Assumes the
-- | generator is a finite generator.
smallCheck :: forall eff prop. Testable prop => prop -> SC eff Unit
smallCheck prop = do
  seed <- randomSeed
  check (smallCheckPure seed) prop

-- | Exhaustively checks the proposition for all possible values in a pure
-- | setting, returning an array of results. Assumes the generator is a finite
-- | generator.
smallCheckPure :: forall prop. Testable prop => Seed -> prop -> Array (Tuple Seed Result)
smallCheckPure s prop = runTrampoline $ collectAll (defState s) (decorateSeed (test prop))

-- | Checks that the proposition has a certain probability of being true for
-- | arbitrary values.
statCheck :: forall eff prop. Testable prop => Number -> prop -> SC eff Unit
statCheck freq prop = do
  seed <- randomSeed
  log <<< show $ statCheckPure seed freq prop

-- | Checks that the proposition has a certain probability of being true for
-- | arbitrary values in a pure setting, returning a result.
statCheckPure :: forall prop. Testable prop => Seed -> Number -> prop -> Result
statCheckPure s freq prop = try 100
  where
  try :: Int -> Result
  try x =
    let
      measure :: Int -> Number
      measure n =
        let results = quickCheckPure n s prop
        in Int.toNumber $ (countSuccesses results) / (A.length results)

      measure' :: Int -> Array Number
      measure' 0 = []
      measure' n = measure' (n - 1) <> [measure (n * x)]

      freqs :: Array Number
      freqs = measure' 4

      dists :: Array Number
      dists = (Math.abs <<< (-) freq) <$> freqs

      dirs :: Array Number
      dirs  = A.zipWith (\a b -> a - b) ([1.0] <> dists) dists

      fails :: Int
      fails = A.length $ A.filter ((>) 0.0) dirs

      succs :: Array Number
      succs = A.filter ((<=) 0.0) dirs
    in
      if fails > 1
      then
        if x < 1000000 then try (x * 10)
        else Failed $ "Divergence of statistical test: freqs = " <> show freqs <> ", dists = " <> show dists <> ", dirs = " <> show dirs <> ", fails: " <> show fails
      else maybe (Failed "Error!") (\l -> if l > 0.5 then Failed $ "Final convergence distance too low: " <> show l else Success) (A.last succs)

defState :: Seed -> GenState
defState s = (GenState {seed: s, size: 10})

check :: forall eff prop f. (Testable prop, Foldable f) => (prop -> f (Tuple Seed Result)) -> prop -> SC eff Unit
check f prop = do
  let results = f prop
  let successes = countSuccesses results
  log $ show successes <> "/" <> show (length $ List.fromFoldable results) <> " test(s) passed."
  throwOnFirstFailure 1 results

throwOnFirstFailure :: forall eff f. Foldable f => Int -> f (Tuple Seed Result) -> SC eff Unit
throwOnFirstFailure n fr = throwOnFirstFailure' n (List.fromFoldable fr)
  where
  throwOnFirstFailure' :: Int -> List (Tuple Seed Result) -> SC eff Unit
  throwOnFirstFailure' _ Nil = pure unit
  throwOnFirstFailure' n' (Cons (Tuple seed (Failed msg)) _) = throwException $ error $ "Test " <> show n' <> " (seed " <> show (runSeed seed) <> ") failed: \n" <> msg
  throwOnFirstFailure' n' (Cons _ rest) = throwOnFirstFailure (n' + 1) rest

countSuccesses :: forall f. Foldable f => f (Tuple Seed Result) -> Int
countSuccesses fa = countSuccesses' 0 (List.fromFoldable fa)
  where
  countSuccesses' acc Nil = acc
  countSuccesses' acc (Cons (Tuple _ Success) rest) = countSuccesses' (acc + 1) rest
  countSuccesses' acc (Cons _ rest) = countSuccesses' acc rest

-- | Checks that the specified proposition holds. Useful for unit tests.
assert :: forall eff prop. Testable prop => prop -> SC eff Unit
assert = quickCheck' 1

-- | Converts a `Boolean` into a `Result` by lifting a message into `Failed`
-- | when the boolean is `false`.
annotate :: Boolean -> String -> Result
annotate true = const Success
annotate false = Failed

infix 1 annotate as <?>

-- | Asserts that two values are equal, resulting in a `Failure` if they are
-- | not, with a message showing the values involved.
assertEq :: forall a. (Eq a, Show a) => a -> a -> Result
assertEq a b = a == b <?> msg
  where
  msg = show a <> " /= " <> show b

infix 2 assertEq as ===

-- | Asserts that two values are not equal, resulting in a `Failure` if they
-- | are, with a message showing the values involved.
assertNotEq :: forall a. (Eq a, Show a) => a -> a -> Result
assertNotEq a b = a /= b <?> msg
  where
  msg = show a <> " == " <> show b

infix 2 assertNotEq as /==


Add left and right varieties of bitraverse/bifor

module Data.Bitraversable
  ( class Bitraversable, bitraverse, bisequence
  , bitraverseDefault
  , bisequenceDefault
  , ltraverse
  , rtraverse
  , bifor
  , lfor
  , rfor
  , module Data.Bifoldable
  ) where

import Prelude

import Data.Bifoldable (class Bifoldable, biall, biany, bifold, bifoldMap, bifoldMapDefaultL, bifoldMapDefaultR, bifoldl, bifoldlDefault, bifoldr, bifoldrDefault, bifor_, bisequence_, bitraverse_)
import Data.Bifunctor (class Bifunctor, bimap)

-- | `Bitraversable` represents data structures with two type arguments which can be
-- | traversed.
-- |
-- | A traversal for such a structure requires two functions, one for each type
-- | argument. Type class instances should choose the appropriate function based
-- | on the type of the element encountered at each point of the traversal.
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `bitraverseDefault`
-- | - `bisequenceDefault`
class (Bifunctor t, Bifoldable t) <= Bitraversable t where
  bitraverse :: forall f a b c d. Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
  bisequence :: forall f a b. Applicative f => t (f a) (f b) -> f (t a b)

ltraverse
  :: forall t b c a f
   . (Bitraversable t, Applicative f)
  => (a -> f c)
  -> t a b
  -> f (t c b)
ltraverse f = bitraverse f pure

rtraverse
  :: forall t b c a f
   . (Bitraversable t, Applicative f)
  => (b -> f c)
  -> t a b
  -> f (t a c)
rtraverse = bitraverse pure

-- | A default implementation of `bitraverse` using `bisequence` and `bimap`.
bitraverseDefault
  :: forall t f a b c d
   . (Bitraversable t, Applicative f)
  => (a -> f c)
  -> (b -> f d)
  -> t a b
  -> f (t c d)
bitraverseDefault f g t = bisequence (bimap f g t)

-- | A default implementation of `bisequence` using `bitraverse`.
bisequenceDefault
  :: forall t f a b
   . (Bitraversable t, Applicative f)
  => t (f a) (f b)
  -> f (t a b)
bisequenceDefault t = bitraverse id id t

-- | Traverse a data structure, accumulating effects and results using an `Applicative` functor.
bifor
  :: forall t f a b c d
   . (Bitraversable t, Applicative f)
  => t a b
  -> (a -> f c)
  -> (b -> f d)
  -> f (t c d)
bifor t f g = bitraverse f g t

lfor
  :: forall t b c a f
   . (Bitraversable t, Applicative f)
  => t a b
  -> (a -> f c)
  -> f (t c b)
lfor t f = bitraverse f pure t

rfor
  :: forall t b c a f
   . (Bitraversable t, Applicative f)
  => t a b
  -> (b -> f c)
  -> f (t a c)
rfor t f = bitraverse pure f t

module Data.Bitraversable
  ( class Bitraversable, bitraverse, bisequence
  , bitraverseDefault
  , bisequenceDefault
  , bifor
  , module Data.Bifoldable
  ) where

import Prelude

import Data.Bifoldable (class Bifoldable, biall, biany, bifold, bifoldMap, bifoldMapDefaultL, bifoldMapDefaultR, bifoldl, bifoldlDefault, bifoldr, bifoldrDefault, bifor_, bisequence_, bitraverse_)
import Data.Bifunctor (class Bifunctor, bimap)

-- | `Bitraversable` represents data structures with two type arguments which can be
-- | traversed.
-- |
-- | A traversal for such a structure requires two functions, one for each type
-- | argument. Type class instances should choose the appropriate function based
-- | on the type of the element encountered at each point of the traversal.
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `bitraverseDefault`
-- | - `bisequenceDefault`
class (Bifunctor t, Bifoldable t) <= Bitraversable t where
  bitraverse :: forall f a b c d. Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
  bisequence :: forall f a b. Applicative f => t (f a) (f b) -> f (t a b)

-- | A default implementation of `bitraverse` using `bisequence` and `bimap`.
bitraverseDefault
  :: forall t f a b c d
   . (Bitraversable t, Applicative f)
  => (a -> f c)
  -> (b -> f d)
  -> t a b
  -> f (t c d)
bitraverseDefault f g t = bisequence (bimap f g t)

-- | A default implementation of `bisequence` using `bitraverse`.
bisequenceDefault
  :: forall t f a b
   . (Bitraversable t, Applicative f)
  => t (f a) (f b)
  -> f (t a b)
bisequenceDefault t = bitraverse id id t

-- | Traverse a data structure, accumulating effects and results using an `Applicative` functor.
bifor
  :: forall t f a b c d
   . (Bitraversable t, Applicative f)
  => t a b
  -> (a -> f c)
  -> (b -> f d)
  -> f (t c d)
bifor t f g = bitraverse f g t