simplify `append` definition

simplify `append` definition

now `append` definition is same as `link`, so simply forward to `link`.

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , length
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.CatQueue as Q
import Data.Foldable (class Foldable, foldMapDefaultL)
import Data.Foldable as Foldable
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatList a -> Int
length = Foldable.length

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append = link

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link cat CatNil = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

-- | Running time: `O(1)`
instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap = foldMapDefaultL
  foldr f s l = Foldable.foldrDefault f s l
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance unfoldable1CatList :: Unfoldable1 CatList where
  unfoldr1 f b = go b CatNil
    where
      go source memo = case f source of
        Tuple one Nothing -> snoc memo one
        Tuple one (Just rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map _ CatNil = CatNil
  map f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in f a `cons` map f d

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , length
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.CatQueue as Q
import Data.Foldable (class Foldable, foldMapDefaultL)
import Data.Foldable as Foldable
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatList a -> Int
length = Foldable.length

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link cat CatNil = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

-- | Running time: `O(1)`
instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap = foldMapDefaultL
  foldr f s l = Foldable.foldrDefault f s l
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance unfoldable1CatList :: Unfoldable1 CatList where
  unfoldr1 f b = go b CatNil
    where
      go source memo = case f source of
        Tuple one Nothing -> snoc memo one
        Tuple one (Just rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map _ CatNil = CatNil
  map f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in f a `cons` map f d

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList


export dnd action sequences

export dnd action sequences


Add subclasses to enforce the type class laws

-- | This module defines the `MonadWriter` type class and its instances.

module Control.Monad.Writer.Class where

import Prelude

import Data.Tuple (Tuple(..))

-- | The `MonadTell w` type class represents those monads which support a
-- | monoidal accumulator of type `w`, where `tell` appends a value to the
-- | accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
class (Semigroup w, Monad m) <= MonadTell w m | m -> w where
  tell :: w -> m Unit

-- | An extension of the `MonadTell` class that introduces some operations on
-- | the accumulator:
-- |
-- | - `listen` modifies the result to include the changes to the accumulator.
-- | - `pass` applies the returned function to the accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Laws in addition to the `MonadTell` law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
-- | - `listen (pure a) = pure (Tuple a mempty)`
-- | - `listen (writer a x) = tell x $> Tuple a x`
class (Monoid w, MonadTell w m) <= MonadWriter w m | m -> w where
  listen :: forall a. m a -> m (Tuple a w)
  pass :: forall a. m (Tuple a (w -> w)) -> m a

-- | Projects a value from modifications made to the accumulator during an
-- | action.
listens :: forall w m a b. MonadWriter w m => (w -> b) -> m a -> m (Tuple a b)
listens f m = do
  Tuple a w <- listen m
  pure $ Tuple a (f w)

-- | Modify the final accumulator value by applying a function.
censor :: forall w m a. MonadWriter w m => (w -> w) -> m a -> m a
censor f m = pass do
  a <- m
  pure $ Tuple a f

-- | This module defines the `MonadWriter` type class and its instances.

module Control.Monad.Writer.Class where

import Prelude

import Data.Tuple (Tuple(..))

-- | The `MonadTell w` type class represents those monads which support a
-- | monoidal accumulator of type `w`, where `tell` appends a value to the
-- | accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
class Monad m <= MonadTell w m | m -> w where
  tell :: w -> m Unit

-- | An extension of the `MonadTell` class that introduces some operations on
-- | the accumulator:
-- |
-- | - `listen` modifies the result to include the changes to the accumulator.
-- | - `pass` applies the returned function to the accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Laws in addition to the `MonadTell` law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
-- | - `listen (pure a) = pure (Tuple a mempty)`
-- | - `listen (writer a x) = tell x $> Tuple a x`
class MonadTell w m <= MonadWriter w m | m -> w where
  listen :: forall a. m a -> m (Tuple a w)
  pass :: forall a. m (Tuple a (w -> w)) -> m a

-- | Projects a value from modifications made to the accumulator during an
-- | action.
listens :: forall w m a b. MonadWriter w m => (w -> b) -> m a -> m (Tuple a b)
listens f m = do
  Tuple a w <- listen m
  pure $ Tuple a (f w)

-- | Modify the final accumulator value by applying a function.
censor :: forall w m a. MonadWriter w m => (w -> w) -> m a -> m a
censor f m = pass do
  a <- m
  pure $ Tuple a f


Don't reverse the results when reading json

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Api.Common (getResponse, succeeded)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Data.DOM.Simple.Encode (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name, parent)
import Network.HTTP.Affjax (Affjax(), AJAX(), get, affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core ((^.))
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (ajax :: AJAX | e) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ get uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (ajax :: AJAX | e) Number
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Number
  readTotal = toNumber <=< lookup "total" <=< toObject <=< head

foreign import unconsNative """
  function unconsNative (empty) {
    return function (next) {
      return function (xs) {
        return xs.length === 0 ? empty({}) : next(xs[0])(xs.slice(1));
      };
    };
  }
  """ :: forall a b. (Unit -> b) ->
                     (a -> Array a -> b) ->
                     Array a ->
                     b

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (ajax :: AJAX | e) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- affjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
  uncons = unconsNative (const Nothing) \x xs -> Just { head: x, tail: xs }

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe I.Int -> Maybe I.Int -> Aff (ajax :: AJAX |e) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else (readValue <$>) <$> (extractJArray <$> (getResponse msg $ get uri))
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show <<< I.toNumber) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show <<< I.toNumber) mbLimit)

sample :: forall e. Resource -> I.Int -> I.Int -> Aff (ajax :: AJAX | e) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (ajax :: AJAX | e) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (ajax :: AJAX | e) [String]
fields res = do
  jarr <- sample res (I.fromNumber 0) (I.fromNumber 100)
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> [String]
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: [String] -> Json -> [String]
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: [String] -> JArray -> [String]
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: [String] -> JObject -> [String]
goObj acc obj = concat $ (goTuple acc <$> (toList obj))

goTuple :: [String] -> Tuple String Json -> [String]
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

-- temporary files are written to `value` field or even `value.value`
readValue :: Json -> Json
readValue json = fromObject $ fromRight do
  obj <- decodeJson json
  if keys obj == ["value"]
    then let value :: Either _ JObject
             value = obj .? "value" in
         if keys <$> value == pure ["value"]
         then (.? "value") >=> (.? "value") $ obj
         else value
    else pure obj

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Api.Common (getResponse, succeeded)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Data.DOM.Simple.Encode (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name, parent)
import Network.HTTP.Affjax (Affjax(), AJAX(), get, affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core ((^.))
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (ajax :: AJAX | e) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ get uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (ajax :: AJAX | e) Number
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Number
  readTotal = toNumber <=< lookup "total" <=< toObject <=< head

foreign import unconsNative """
  function unconsNative (empty) {
    return function (next) {
      return function (xs) {
        return xs.length === 0 ? empty({}) : next(xs[0])(xs.slice(1));
      };
    };
  }
  """ :: forall a b. (Unit -> b) ->
                     (a -> Array a -> b) ->
                     Array a ->
                     b

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (ajax :: AJAX | e) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- affjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
  uncons = unconsNative (const Nothing) \x xs -> Just { head: x, tail: xs }

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe I.Int -> Maybe I.Int -> Aff (ajax :: AJAX |e) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else (readValue <$>) <$> (extractJArray <$> (getResponse msg $ get uri))
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show <<< I.toNumber) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show <<< I.toNumber) mbLimit)

sample :: forall e. Resource -> I.Int -> I.Int -> Aff (ajax :: AJAX | e) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (ajax :: AJAX | e) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (ajax :: AJAX | e) [String]
fields res = do
  jarr <- sample res (I.fromNumber 0) (I.fromNumber 100)
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = j:agg
  folder agg _ = agg

getFields :: Json -> [String]
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: [String] -> Json -> [String]
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: [String] -> JArray -> [String]
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: [String] -> JObject -> [String]
goObj acc obj = concat $ (goTuple acc <$> (toList obj))

goTuple :: [String] -> Tuple String Json -> [String]
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

-- temporary files are written to `value` field or even `value.value`
readValue :: Json -> Json
readValue json = fromObject $ fromRight do
  obj <- decodeJson json
  if keys obj == ["value"]
    then let value :: Either _ JObject
             value = obj .? "value" in
         if keys <$> value == pure ["value"]
         then (.? "value") >=> (.? "value") $ obj
         else value
    else pure obj


fix Input Error bug

fix Input Error bug

module SimScreen where

import Prelude

import Data.Int
import Data.Lens
import Data.Maybe
import Data.Either
import Data.Traversable
import Data.List as List
import Data.String (split, length, take, drop)
import Data.String as Str
import Control.Monad.Eff
import Control.Monad.Aff
import Graphics.Canvas as C

import Utils
import CanvasUtils
import Zipper
import TextBar as T
import Input as I
import Machine as M

-- import Debug.Trace

-----------
-- Model
-----------

data State
  = ShowInput
  | ShowOutput
  | ShowMachine
  | RunMachine
  | TestMachine
  | ShowError String
  | Done

type Test =
  { input :: List.List Int, output :: List.List Int }

type SimScreen
  = { code :: List.List String
    , currLine :: String
    , currInput :: String
    , gfx :: C.CanvasImageSource
    , compRun :: Boolean
    , inputs  :: List.List String
    , outputs :: List.List Int
    , machine :: Maybe M.Machine
    , tests :: Zipper Test
    , state :: State
    }

mkSimScreen :: Zipper Test -> C.CanvasImageSource -> SimScreen
mkSimScreen tests img =
  { code: List.Nil
  , currInput: ""
  , currLine: ""
  , gfx: img
  , compRun: false
  , inputs: List.Nil
  , outputs: List.Nil
  , machine: Nothing
  , tests: tests
  , state: ShowMachine
  }

mkCompScreen :: Zipper Test -> Aff _ SimScreen
mkCompScreen tests = do
  map (mkSimScreen tests) $ loadImageData "assets/comp2.png"

done :: SimScreen -> Boolean
done state =
  case state.state of
    Done -> true
    _ -> false

------------
-- Update
------------

zeroButton =
  { pos:  { x: 315.0, y: 630.0 }
  , size: { x: 131.0, y: 80.0 }
  }

oneButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

resetButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

runButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

updateMouseInput i =
  case i.mouseClick of
    Nothing ->
      i
    Just p ->
      if p `pointInRect` zeroButton then
        set (I.zeroOne <<< I.zero) true i
      else if p `pointInRect` oneButton then
        set (I.zeroOne <<< I.one) true i
      else
        i

update :: I.Input -> SimScreen -> SimScreen
update i state =
  let input = updateMouseInput i
  in
   updateState input $
   resetMachine input $
   updateCode input state

updateCode :: I.Input -> SimScreen -> SimScreen
updateCode input state =
  case state.state of
    ShowMachine ->
        let line = state.currLine <> if input.zeroOne.zero then "0" else "" <> if input.zeroOne.one then "1" else ""
        in
            if length line >= 8
            then over code (List.Cons (take 8 line)) $
                set currLine (drop 8 line) state
            else
                set currLine line state
    _ ->
      state

startMachine :: I.Input -> SimScreen -> SimScreen
startMachine input state =
    if isJust state.machine then
      state { machine = Nothing }
    else
      let insts = traverse M.translate $ List.reverse state.code
      in case insts of
        Left err ->
          state { state = ShowError $ "Code load failed: " <> show err <> "." }
        Right is ->
          case traverse M.strBinToInt state.inputs of
            Left err ->
              state { state = ShowError $ "Input load failed: " <> show err <> "." }
            Right inputs ->
              state { machine = M.mkMachine is inputs }

tryEval :: M.Machine -> M.Machine
tryEval machine =
  case M.eval machine of
    Left _ -> machine
    Right m -> m

resetMachine :: I.Input -> SimScreen -> SimScreen
resetMachine input state =
  if input.screenDir < 0.0 then
    case state.state of
      ShowMachine ->
        state { machine = Nothing, code = List.Nil, inputs = List.Nil, outputs = List.Nil, currLine = "" }
      ShowOutput ->
        state { state = ShowMachine }
      ShowInput ->
        state { state = ShowMachine }
      ShowError _ ->
        state { state = ShowMachine, machine = Nothing }
      RunMachine ->
        state { state = ShowMachine, machine = Nothing }
      TestMachine ->
        state { state = ShowMachine, machine = Nothing }
      Done ->
        state
  else
    state

updateState :: I.Input -> SimScreen -> SimScreen
updateState input state =
  case state.state of
    ShowMachine ->
      if fst input.io then
        state { state = ShowInput }
      else if snd input.io then
        state { state = ShowOutput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    ShowInput -> updateInput input $
      if fst input.io then
        state { state = ShowMachine }
      else if snd input.io then
        state { state = ShowOutput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    ShowOutput ->
      if snd input.io then
        state { state = ShowMachine }
      else if fst input.io then
        state { state = ShowInput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    TestMachine ->
      case state.machine of
        Nothing ->
          runTest $ state { tests = start state.tests }
        Just mch ->
          if M.halted mch then
            case M.hasErrors mch of
              Just err ->
                state { state = ShowError $ "Run failed: " <> show err <> "." }
              Nothing ->
                if (current state.tests).output == mch.output then
                  if fst $ next state.tests then
                    runTest $ state { tests = snd $ next state.tests }
                  else
                    state { state = Done }
                else
                  state { state = ShowError $ "Test failed: input was: " <> show (current state.tests).input <> ", expected output was: " <> show (List.reverse (current state.tests).output) <> ". got: " <> show (List.reverse mch.output) <> "." }
          else case M.eval mch of
            Left err ->
              state { state = ShowError $ "Run failed: " <> show err <> "." }
            Right newMachine ->
              state { machine = Just newMachine }

    RunMachine -> do
        case state.machine of
          Just m ->
            if M.halted m then
              case M.hasErrors m of
                Just err ->
                  state { state = ShowError $ "Run failed: " <> show err <> "." }
                Nothing ->
                  state { state = ShowOutput, outputs = m.output, machine = Nothing }
            else
              case M.eval m of
                Left err ->
                  state { state = ShowError $ "Run failed: " <> show err <> "." }
                Right newMachine ->
                  state { machine = Just newMachine }

          Nothing ->
            startMachine input state
    _ ->
      state

    Done ->
      state
    ShowError _ ->
      if input.screenDir < 0.0 then
        state { machine = Nothing, state = ShowMachine }
      else
        state

runTest state =
  let insts = traverse M.translate $ List.reverse state.code
  in case insts of
    Left err ->
      state { state = ShowError $ "Loading Code failed: " <> show err <> "." }
    Right is ->
      state { machine = M.mkMachine is (current state.tests).input }

updateInput :: I.Input -> SimScreen -> SimScreen
updateInput input state =
  case state.state of
    ShowInput ->
      let line = state.currInput <> if input.zeroOne.zero then "0" else "" <> if input.zeroOne.one then "1" else ""
      in
        if length line >= 5
        then over inputs (List.Cons (take 5 line)) $
            set currInput (drop 5 line) state
        else
            set currInput line state
    _ -> state

------------
-- Render
------------

render :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
render ctx screen = do
  C.drawImage ctx screen.gfx 0.0 0.0
  C.setFillStyle "#CC3388" ctx

  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 350.0 230.0) $ List.range 0 40) (List.reverse screen.code)

  C.setFont "18px monospace" ctx

  case screen.state of
    ShowMachine -> do
      renderMachine ctx screen
    ShowInput ->
      renderInput ctx screen
    ShowOutput ->
      renderOutput ctx screen
    RunMachine ->
      pure unit
    TestMachine -> do
      renderMachine ctx screen
      renderInput ctx screen
      renderOutput ctx screen
    ShowError err ->
      renderError err ctx screen
    Done ->
      renderDone ctx screen

  case screen.state of
    ShowMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Zeros and Ones" 120.0 40.0
    ShowInput -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Inputs" 120.0 40.0
    ShowOutput -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Outputs" 120.0 40.0
    TestMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Running Tests..." 120.0 40.0
    RunMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Running..." 120.0 40.0
    ShowError err -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Error" 120.0 40.0
    Done -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Done" 120.0 40.0

  pure unit

getPosition x y i =
  { x: x + 100.0 * toNumber (i `div` 8)
  , y: y + 30.0  * toNumber (i `mod` 8)
  }

renderMachine :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderMachine ctx screen = do
  C.setFillStyle "#DD4499" ctx
  C.fillText ctx ("> " <> screen.currLine) 350.0 (230.0 + 30.0 * 8.0)
  pure unit

renderOutput :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderOutput ctx screen = do
  C.setFillStyle "rgba(235,235,255,0.9)" ctx
  C.fillRect ctx { x: 700.0, y: 100.0, w: 300.0, h: 400.0 }
  C.setFillStyle "#004499" ctx
  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 740.0 150.0) $ List.range 0 8) (List.reverse $ map show screen.outputs)
  pure unit

renderInput :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderInput ctx screen = do
  C.setFillStyle "rgba(235,235,255,0.9)" ctx
  C.fillRect ctx { x: 40.0, y: 100.0, w: 300.0, h: 400.0 }
  C.setFillStyle "#004499" ctx
  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 80.0 150.0) $ List.range 0 8) (List.reverse screen.inputs)

  C.setFillStyle "#DD4499" ctx
  C.fillText ctx ("> " <> screen.currInput) 80.0 (150.0 + 30.0 * 10.0)

  pure unit

renderError :: String -> C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderError err ctx state = do
  C.setFillStyle "rgba(235,135,155,0.9)" ctx
  C.fillRect ctx { x: 80.0, y: 20.0, w: width - 160.0, h: 100.0 }
  C.setFillStyle "white" ctx
  C.setFont "16px monospace" ctx
  let texts = map (splitLine err) (List.range 0 (Str.length err / 80))
  sequence $ List.zipWith (\i text -> C.fillText ctx text 120.0 (60.0 + 30.0 * toNumber i)) (List.range 0 (List.length texts)) texts
  C.setFont "18px monospace" ctx

  pure unit

renderDone :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderDone ctx state = do
  C.setFillStyle "rgba(35,235,155,0.9)" ctx
  C.fillRect ctx { x: 80.0, y: 20.0, w: width - 160.0, h: 100.0 }
  C.setFillStyle "white" ctx
  C.fillText ctx "Great Job!" 120.0 60.0
  pure unit

splitLine text i =
  let n = i * 80
  in
    case Str.uncons $ Str.drop (n+79) text of
      Nothing ->
        Str.take 80 $ Str.drop n text
      Just {head: x, tail: xs} ->
        if x == ' ' then
          Str.take 80 $ Str.drop n text
        else case Str.uncons $ Str.drop (n+80) text of
          Nothing ->
            Str.take 80 $ Str.drop n text
          Just {head: x, tail: xs} ->
            if x == ' ' then
              Str.take 80 $ Str.drop n text
            else
              (Str.take 80 $ Str.drop n text) <> "-"

---------------------

currInput = lens _.currInput (_ { currInput = _ })
currLine = lens _.currLine (_ { currLine = _ })
code = lens _.code (_ { code = _ })
inputs = lens _.inputs (_ { inputs = _ })

module SimScreen where

import Prelude

import Data.Int
import Data.Lens
import Data.Maybe
import Data.Either
import Data.Traversable
import Data.List as List
import Data.String (split, length, take, drop)
import Data.String as Str
import Control.Monad.Eff
import Control.Monad.Aff
import Graphics.Canvas as C

import Utils
import CanvasUtils
import Zipper
import TextBar as T
import Input as I
import Machine as M

-- import Debug.Trace

-----------
-- Model
-----------

data State
  = ShowInput
  | ShowOutput
  | ShowMachine
  | RunMachine
  | TestMachine
  | ShowError String
  | Done

type Test =
  { input :: List.List Int, output :: List.List Int }

type SimScreen
  = { code :: List.List String
    , currLine :: String
    , currInput :: String
    , gfx :: C.CanvasImageSource
    , compRun :: Boolean
    , inputs  :: List.List String
    , outputs :: List.List Int
    , machine :: Maybe M.Machine
    , tests :: Zipper Test
    , state :: State
    }

mkSimScreen :: Zipper Test -> C.CanvasImageSource -> SimScreen
mkSimScreen tests img =
  { code: List.Nil
  , currInput: ""
  , currLine: ""
  , gfx: img
  , compRun: false
  , inputs: List.Nil
  , outputs: List.Nil
  , machine: Nothing
  , tests: tests
  , state: ShowMachine
  }

mkCompScreen :: Zipper Test -> Aff _ SimScreen
mkCompScreen tests = do
  map (mkSimScreen tests) $ loadImageData "assets/comp2.png"

done :: SimScreen -> Boolean
done state =
  case state.state of
    Done -> true
    _ -> false

------------
-- Update
------------

zeroButton =
  { pos:  { x: 315.0, y: 630.0 }
  , size: { x: 131.0, y: 80.0 }
  }

oneButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

resetButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

runButton =
  { pos:  { x: 497.0, y: 627.0 }
  , size: { x: 134.0, y: 82.0 }
  }

updateMouseInput i =
  case i.mouseClick of
    Nothing ->
      i
    Just p ->
      if p `pointInRect` zeroButton then
        set (I.zeroOne <<< I.zero) true i
      else if p `pointInRect` oneButton then
        set (I.zeroOne <<< I.one) true i
      else
        i

update :: I.Input -> SimScreen -> SimScreen
update i state =
  let input = updateMouseInput i
  in
   updateState input $
   resetMachine input $
   updateCode input state

updateCode :: I.Input -> SimScreen -> SimScreen
updateCode input state =
  case state.state of
    ShowMachine ->
        let line = state.currLine <> if input.zeroOne.zero then "0" else "" <> if input.zeroOne.one then "1" else ""
        in
            if length line >= 8
            then over code (List.Cons (take 8 line)) $
                set currLine (drop 8 line) state
            else
                set currLine line state
    _ ->
      state

startMachine :: I.Input -> SimScreen -> SimScreen
startMachine input state =
    if isJust state.machine then
      state { machine = Nothing }
    else
      let insts = traverse M.translate $ List.reverse state.code
      in case insts of
        Left err ->
          state { state = ShowError $ "Code load failed: " <> show err <> "." }
        Right is ->
          case traverse M.strBinToInt state.inputs of
            Left err ->
              state { state = ShowError $ "Input load failed: " <> show err <> "." }
            Right inputs ->
              state { machine = M.mkMachine is inputs }

tryEval :: M.Machine -> M.Machine
tryEval machine =
  case M.eval machine of
    Left _ -> machine
    Right m -> m

resetMachine :: I.Input -> SimScreen -> SimScreen
resetMachine input state =
  if input.screenDir < 0.0 then
    case state.state of
      ShowMachine ->
        state { machine = Nothing, code = List.Nil, inputs = List.Nil, outputs = List.Nil, currLine = "" }
      ShowOutput ->
        state { state = ShowMachine }
      ShowInput ->
        state { state = ShowMachine }
      ShowError _ ->
        state { state = ShowMachine }
      RunMachine ->
        state { state = ShowMachine, machine = Nothing }
      TestMachine ->
        state { state = ShowMachine, machine = Nothing }
      Done ->
        state
  else
    state

updateState :: I.Input -> SimScreen -> SimScreen
updateState input state =
  case state.state of
    ShowMachine ->
      if fst input.io then
        state { state = ShowInput }
      else if snd input.io then
        state { state = ShowOutput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    ShowInput -> updateInput input $
      if fst input.io then
        state { state = ShowMachine }
      else if snd input.io then
        state { state = ShowOutput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    ShowOutput ->
      if snd input.io then
        state { state = ShowMachine }
      else if fst input.io then
        state { state = ShowInput }
      else if input.runTests then
        state { state = TestMachine }
      else if input.screenDir > 0.0 then
        state { state = RunMachine }
      else
        state
    TestMachine ->
      case state.machine of
        Nothing ->
          runTest $ state { tests = start state.tests }
        Just mch ->
          if M.halted mch then
            case M.hasErrors mch of
              Just err ->
                state { state = ShowError $ "Run failed: " <> show err <> "." }
              Nothing ->
                if (current state.tests).output == mch.output then
                  if fst $ next state.tests then
                    runTest $ state { tests = snd $ next state.tests }
                  else
                    state { state = Done }
                else
                  state { state = ShowError $ "Test failed: input was: " <> show (current state.tests).input <> ", expected output was: " <> show (List.reverse (current state.tests).output) <> ". got: " <> show (List.reverse mch.output) <> "." }
          else case M.eval mch of
            Left err ->
              state { state = ShowError $ "Run failed: " <> show err <> "." }
            Right newMachine ->
              state { machine = Just newMachine }

    RunMachine -> do
        case state.machine of
          Just m ->
            if M.halted m then
              case M.hasErrors m of
                Just err ->
                  state { state = ShowError $ "Run failed: " <> show err <> "." }
                Nothing ->
                  state { state = ShowOutput, outputs = m.output, machine = Nothing }
            else
              case M.eval m of
                Left err ->
                  state { state = ShowError $ "Run failed: " <> show err <> "." }
                Right newMachine ->
                  state { machine = Just newMachine }

          Nothing ->
            startMachine input state
    _ ->
      state

    Done ->
      state
    ShowError _ ->
      if input.screenDir < 0.0 then
        state { machine = Nothing, state = ShowMachine }
      else
        state

runTest state =
  let insts = traverse M.translate $ List.reverse state.code
  in case insts of
    Left err ->
      state { state = ShowError $ "Loading Code failed: " <> show err <> "." }
    Right is ->
      state { machine = M.mkMachine is (current state.tests).input }

updateInput :: I.Input -> SimScreen -> SimScreen
updateInput input state =
  case state.state of
    ShowInput ->
      let line = state.currInput <> if input.zeroOne.zero then "0" else "" <> if input.zeroOne.one then "1" else ""
      in
        if length line >= 5
        then over inputs (List.Cons (take 5 line)) $
            set currInput (drop 5 line) state
        else
            set currInput line state
    _ -> state

------------
-- Render
------------

render :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
render ctx screen = do
  C.drawImage ctx screen.gfx 0.0 0.0
  C.setFillStyle "#CC3388" ctx

  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 350.0 230.0) $ List.range 0 40) (List.reverse screen.code)

  C.setFont "18px monospace" ctx

  case screen.state of
    ShowMachine -> do
      renderMachine ctx screen
    ShowInput ->
      renderInput ctx screen
    ShowOutput ->
      renderOutput ctx screen
    RunMachine ->
      pure unit
    TestMachine -> do
      renderMachine ctx screen
      renderInput ctx screen
      renderOutput ctx screen
    ShowError err ->
      renderError err ctx screen
    Done ->
      renderDone ctx screen

  case screen.state of
    ShowMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Zeros and Ones" 120.0 40.0
    ShowInput -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Inputs" 120.0 40.0
    ShowOutput -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Outputs" 120.0 40.0
    TestMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Running Tests..." 120.0 40.0
    RunMachine -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Running..." 120.0 40.0
    ShowError err -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Error" 120.0 40.0
    Done -> do
        C.setFillStyle "white" ctx
        C.fillText ctx "Done" 120.0 40.0

  pure unit

getPosition x y i =
  { x: x + 100.0 * toNumber (i `div` 8)
  , y: y + 30.0  * toNumber (i `mod` 8)
  }

renderMachine :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderMachine ctx screen = do
  C.setFillStyle "#DD4499" ctx
  C.fillText ctx ("> " <> screen.currLine) 350.0 (230.0 + 30.0 * 8.0)
  pure unit

renderOutput :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderOutput ctx screen = do
  C.setFillStyle "rgba(235,235,255,0.9)" ctx
  C.fillRect ctx { x: 700.0, y: 100.0, w: 300.0, h: 400.0 }
  C.setFillStyle "#004499" ctx
  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 740.0 150.0) $ List.range 0 8) (List.reverse $ map show screen.outputs)
  pure unit

renderInput :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderInput ctx screen = do
  C.setFillStyle "rgba(235,235,255,0.9)" ctx
  C.fillRect ctx { x: 40.0, y: 100.0, w: 300.0, h: 400.0 }
  C.setFillStyle "#004499" ctx
  sequence $ List.zipWith (\p txt -> C.fillText ctx txt p.x p.y) (map (getPosition 80.0 150.0) $ List.range 0 8) (List.reverse screen.inputs)

  C.setFillStyle "#DD4499" ctx
  C.fillText ctx ("> " <> screen.currInput) 80.0 (150.0 + 30.0 * 10.0)

  pure unit

renderError :: String -> C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderError err ctx state = do
  C.setFillStyle "rgba(235,135,155,0.9)" ctx
  C.fillRect ctx { x: 80.0, y: 20.0, w: width - 160.0, h: 100.0 }
  C.setFillStyle "white" ctx
  C.setFont "16px monospace" ctx
  let texts = map (splitLine err) (List.range 0 (Str.length err / 80))
  sequence $ List.zipWith (\i text -> C.fillText ctx text 120.0 (60.0 + 30.0 * toNumber i)) (List.range 0 (List.length texts)) texts
  C.setFont "18px monospace" ctx

  pure unit

renderDone :: C.Context2D -> SimScreen -> Eff ( canvas :: C.Canvas | _) Unit
renderDone ctx state = do
  C.setFillStyle "rgba(35,235,155,0.9)" ctx
  C.fillRect ctx { x: 80.0, y: 20.0, w: width - 160.0, h: 100.0 }
  C.setFillStyle "white" ctx
  C.fillText ctx "Great Job!" 120.0 60.0
  pure unit

splitLine text i =
  let n = i * 80
  in
    case Str.uncons $ Str.drop (n+79) text of
      Nothing ->
        Str.take 80 $ Str.drop n text
      Just {head: x, tail: xs} ->
        if x == ' ' then
          Str.take 80 $ Str.drop n text
        else case Str.uncons $ Str.drop (n+80) text of
          Nothing ->
            Str.take 80 $ Str.drop n text
          Just {head: x, tail: xs} ->
            if x == ' ' then
              Str.take 80 $ Str.drop n text
            else
              (Str.take 80 $ Str.drop n text) <> "-"

---------------------

currInput = lens _.currInput (_ { currInput = _ })
currLine = lens _.currLine (_ { currLine = _ })
code = lens _.code (_ { code = _ })
inputs = lens _.inputs (_ { inputs = _ })


Add ForeignError

Add ForeignError

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign
  , ForeignError(..)
  , Prop(..)
  , F
  , parseJSON
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , writeObject
  ) where

import Prelude

import Data.Either (Either(..), either)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Int as Int
import Data.Maybe (maybe)
import Data.NonEmpty as NE
import Data.String (toChar, joinWith)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: *

-- | A type for runtime type errors
data ForeignError
  = ForeignError String
  | TypeMismatch (NE.NonEmpty Array String) String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

instance showForeignError :: Show ForeignError where
  show (ForeignError msg) = "(ForeignError " <> msg <> ")"
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ForeignError msg) = msg
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> show e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> show prop <> ": " <> show e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exps act) = "Type mismatch: expected " <> to_s exps <> ", found " <> act
  where
  to_s (NE.NonEmpty typ []) = typ
  to_s typs = "one of " <> joinWith ", " (NE.oneOf typs)

-- | An error monad, used in this library to encode possible failure when
-- | dealing with foreign data.
type F = Either ForeignError

foreign import parseJSONImpl :: forall r. Fn3 (String -> r) (Foreign -> r) String r

-- | Attempt to parse a JSON string, returning the result as foreign data.
parseJSON :: String -> F Foreign
parseJSON json = runFn3 parseJSONImpl (Left <<< JSONError) Right json

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value | tagOf value == tag = pure (unsafeFromForeign value)
unsafeReadTagged tag value = Left (TypeMismatch (NE.singleton tag) (tagOf value))

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = either (const error) fromString (readString value)
  where
  fromString :: String -> F Char
  fromString = maybe error pure <<< toChar

  error :: F Char
  error = Left $ TypeMismatch (NE.singleton "Char") (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = either (const error) fromNumber (readNumber value)
  where
  fromNumber :: Number -> F Int
  fromNumber = maybe error pure <<< Int.fromNumber

  error :: F Int
  error = Left $ TypeMismatch (NE.singleton "Int") (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value | isArray value = pure $ unsafeFromForeign value
readArray value = Left (TypeMismatch (NE.singleton "array") (tagOf value))

-- | A key/value pair for an object to be written as a `Foreign` value.
newtype Prop = Prop { key :: String, value :: Foreign }

-- | Constructs a JavaScript `Object` value (typed as `Foreign`) from an array
-- | of `Prop`s.
foreign import writeObject :: Array Prop -> Foreign

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign
  , ForeignError(..)
  , Prop(..)
  , F
  , parseJSON
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , writeObject
  ) where

import Prelude

import Data.Either (Either(..), either)
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Int as Int
import Data.Maybe (maybe)
import Data.NonEmpty as NE
import Data.String (toChar, joinWith)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: *

-- | A type for runtime type errors
data ForeignError
  = TypeMismatch (NE.NonEmpty Array String) String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

instance showForeignError :: Show ForeignError where
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> show e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> show prop <> ": " <> show e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exps act) = "Type mismatch: expected " <> to_s exps <> ", found " <> act
  where
  to_s (NE.NonEmpty typ []) = typ
  to_s typs = "one of " <> joinWith ", " (NE.oneOf typs)

-- | An error monad, used in this library to encode possible failure when
-- | dealing with foreign data.
type F = Either ForeignError

foreign import parseJSONImpl :: forall r. Fn3 (String -> r) (Foreign -> r) String r

-- | Attempt to parse a JSON string, returning the result as foreign data.
parseJSON :: String -> F Foreign
parseJSON json = runFn3 parseJSONImpl (Left <<< JSONError) Right json

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value | tagOf value == tag = pure (unsafeFromForeign value)
unsafeReadTagged tag value = Left (TypeMismatch (NE.singleton tag) (tagOf value))

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = either (const error) fromString (readString value)
  where
  fromString :: String -> F Char
  fromString = maybe error pure <<< toChar

  error :: F Char
  error = Left $ TypeMismatch (NE.singleton "Char") (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = either (const error) fromNumber (readNumber value)
  where
  fromNumber :: Number -> F Int
  fromNumber = maybe error pure <<< Int.fromNumber

  error :: F Int
  error = Left $ TypeMismatch (NE.singleton "Int") (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value | isArray value = pure $ unsafeFromForeign value
readArray value = Left (TypeMismatch (NE.singleton "array") (tagOf value))

-- | A key/value pair for an object to be written as a `Foreign` value.
newtype Prop = Prop { key :: String, value :: Foreign }

-- | Constructs a JavaScript `Object` value (typed as `Foreign`) from an array
-- | of `Prop`s.
foreign import writeObject :: Array Prop -> Foreign


Lex the `[default: ...]` token

Lex the `[default: ...]` token

module Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple
import Data.Int
import qualified Data.Int as I
import Global (isNaN, readFloat)

lex :: String -> Either P.ParseError (List PositionedToken)
lex = flip P.runParser parseTokens

data NumberLiteral = FloatLiteral Number | IntLiteral Int

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Defaults String
  | Name String
  | ShoutName String
  | AngleName String
  | Word String
  | StringLiteral String
  | NumberLiteral NumberLiteral
  | Garbage Char

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = show "..."
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Defaults  s)     = "Default "   ++ s
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "String "    ++ show s
prettyPrintToken (NumberLiteral n) = "Number "    ++ show n
prettyPrintToken (Word w)          = "Word "      ++ show w
prettyPrintToken (LOpt n a)        = "--" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)      = "-"
                                        ++ (fromChar n)
                                        ++ (fromCharArray s)
                                        ++ " "
                                        ++ (show a)

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance eqNumberLiteral :: Eq NumberLiteral where
  eq (FloatLiteral n) (FloatLiteral n') = eq n n'
  eq (IntLiteral n)   (IntLiteral n')   = eq n n'

instance showNumberLiteral :: Show NumberLiteral where
  show (FloatLiteral n) = show n
  show (IntLiteral n)   = show n

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n a)        (LOpt n' a')       = (n == n') && (a == a')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq (NumberLiteral n) (NumberLiteral n') = n == n'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ defaults
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ longOption
  , P.try $ shortOption
  , P.try $ AngleName <$> angleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ numberLiteral
  , P.try $ stringLiteral
  , P.try $ ShoutName <$> (shoutName <* P.notFollowedBy alpha)
  , P.try $ Name      <$> (name      <* P.notFollowedBy alpha)
  , P.try $ Word      <$> (word      <* space)
  , P.try $ Garbage   <$> P.anyChar
  ]
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  defaults :: P.Parser String Token
  defaults = Defaults <<< fromCharArray <$>  do
    P.between
      (P.char '[')
      (P.char ']')
      do
        A.many whitespace
        string' "default"
        (void $ P.try $ P.char ':') <|> pure unit
        val <- A.some $ P.noneOf [']']
        A.many whitespace
        pure val

  stringLiteral :: P.Parser String Token
  stringLiteral = StringLiteral <$> do
    P.choice [
      P.between (P.char '\'') (P.char '\'') (p '\'')
    , P.between (P.char '"') (P.char '"') (p '"')
    ]
    where
      p :: Char -> P.Parser String String
      p c = fromCharArray <$> do
        A.many $ P.noneOf [c]

  numberLiteral :: P.Parser String Token
  numberLiteral = NumberLiteral <$> do
    P.choice [
      P.try $ FloatLiteral <$> floatLiteral
    , P.try $ IntLiteral   <$> intLiteral
    ]
    where
      floatLiteral = do
        x <- fromCharArray <$> (A.some num)
        P.char '.'
        xs <- fromCharArray <$> (A.some num)

        -- there is no "safe" version yet, afaik
        let n = readFloat $ x ++ "." ++ xs
        if isNaN n
           then P.fail "Could not parse float"
           else pure n

      intLiteral = do
        x <- fromCharArray <$> (A.some num)
        case (I.fromString x) of
          Just n  -> return n
          Nothing -> P.fail "Could not parse integer"

  name :: P.Parser String String
  name = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  word :: P.Parser String String
  word = fromCharArray <$> do
    (A.some $ P.choice [
      identLetter
    , P.oneOf [ '.', '-', '_' ]
    ])

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    name <- fromCharArray <$> do
      A.cons
        <$> identStart
        <*> (A.many $ P.choice [
              identLetter
            , P.oneOf [ '-' ]
            ])
    P.char '>'
    pure name

  shoutName :: P.Parser String String
  shoutName = do
    name <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    pure name

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- lowerAlphaNum
    xs <- A.many lowerAlphaNum
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `-foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-fooBAR`
    , P.try $ Just <$> do
        fromCharArray <$>
          (A.cons
            <$> upperAlphaNum
            <*> (A.many $ lowerAlphaNum <|> upperAlphaNum))

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"
    name' <- fromCharArray <$> do
      A.cons
        <$> lowerAlphaNum
        <*> (A.many $ P.choice [
              lowerAlphaNum
            , P.oneOf [ '-' ] <* P.lookAhead lowerAlphaNum
            ])
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `--foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `--fooBAR`
    , P.try $ Just <$> do
        fromCharArray <$>
          (A.cons
            <$> upperAlphaNum
            <*> (A.many $ lowerAlphaNum <|> upperAlphaNum))

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser { name :: String
                    , arg  :: Maybe String }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe String }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    go _        = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState
  (ParserState { indentation: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })

module Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple
import Data.Int
import qualified Data.Int as I
import Global (isNaN, readFloat)

lex :: String -> Either P.ParseError (List PositionedToken)
lex = flip P.runParser parseTokens

data NumberLiteral = FloatLiteral Number | IntLiteral Int

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | ShoutName String
  | AngleName String
  | Name String
  | Word String
  | StringLiteral String
  | NumberLiteral NumberLiteral
  | Garbage Char

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = show "..."
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "String " ++ show s
prettyPrintToken (NumberLiteral n) = "Number " ++ show n
prettyPrintToken (Word w)          = "Word " ++ show w
prettyPrintToken (LOpt n a)        = "LOpt --" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)      =
  "SOpt -"
    ++ (fromChar n)
    ++ (fromCharArray s)
    ++ " "
    ++ (show a)

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance eqNumberLiteral :: Eq NumberLiteral where
  eq (FloatLiteral n) (FloatLiteral n') = eq n n'
  eq (IntLiteral n)   (IntLiteral n')   = eq n n'

instance showNumberLiteral :: Show NumberLiteral where
  show (FloatLiteral n) = show n
  show (IntLiteral n)   = show n

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n a)        (LOpt n' a')       = (n == n') && (a == a')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq (NumberLiteral n) (NumberLiteral n') = n == n'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ longOption
  , P.try $ shortOption
  , P.try $ AngleName <$> angleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ numberLiteral
  , P.try $ stringLiteral
  , P.try $ ShoutName <$> (shoutName <* P.notFollowedBy alpha)
  , P.try $ Name      <$> (name      <* P.notFollowedBy alpha)
  , P.try $ Word      <$> (word      <* space)
  , P.try $ Garbage   <$> P.anyChar
  ]
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  stringLiteral :: P.Parser String Token
  stringLiteral = StringLiteral <$> do
    P.choice [
      P.between (P.char '\'') (P.char '\'') (p '\'')
    , P.between (P.char '"') (P.char '"') (p '"')
    ]
    where
      p :: Char -> P.Parser String String
      p c = fromCharArray <$> do
        A.many $ P.noneOf [c]

  numberLiteral :: P.Parser String Token
  numberLiteral = NumberLiteral <$> do
    P.choice [
      P.try $ FloatLiteral <$> floatLiteral
    , P.try $ IntLiteral   <$> intLiteral
    ]
    where
      floatLiteral = do
        x <- fromCharArray <$> (A.some num)
        P.char '.'
        xs <- fromCharArray <$> (A.some num)

        -- there is no "safe" version yet, afaik
        let n = readFloat $ x ++ "." ++ xs
        if isNaN n
           then P.fail "Could not parse float"
           else pure n

      intLiteral = do
        x <- fromCharArray <$> (A.some num)
        case (I.fromString x) of
          Just n  -> return n
          Nothing -> P.fail "Could not parse integer"

  name :: P.Parser String String
  name = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  word :: P.Parser String String
  word = fromCharArray <$> do
    (A.some $ P.choice [
      identLetter
    , P.oneOf [ '.', '-', '_' ]
    ])

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    name <- fromCharArray <$> do
      A.cons
        <$> identStart
        <*> (A.many $ P.choice [
              identLetter
            , P.oneOf [ '-' ]
            ])
    P.char '>'
    pure name

  shoutName :: P.Parser String String
  shoutName = do
    name <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    pure name

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- lowerAlphaNum
    xs <- A.many lowerAlphaNum
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `-foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-fooBAR`
    , P.try $ Just <$> do
        fromCharArray <$>
          (A.cons
            <$> upperAlphaNum
            <*> (A.many $ lowerAlphaNum <|> upperAlphaNum))

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"
    name' <- fromCharArray <$> do
      A.cons
        <$> lowerAlphaNum
        <*> (A.many $ P.choice [
              lowerAlphaNum
            , P.oneOf [ '-' ] <* P.lookAhead lowerAlphaNum
            ])
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `--foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `--fooBAR`
    , P.try $ Just <$> do
        fromCharArray <$>
          (A.cons
            <$> upperAlphaNum
            <*> (A.many $ lowerAlphaNum <|> upperAlphaNum))

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser { name :: String
                    , arg  :: Maybe String }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe String }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    go _        = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState
  (ParserState { indentation: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })


simplified Test.Helper.getDocument

simplified Test.Helper.getDocument

module Test.Helper (
    unsafeFindElement
  , createDomRoot
  , afterAll
  ) where

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent)
import DOM.Node.ParentNode (QuerySelector(QuerySelector), querySelector)
import DOM.Node.Types (Document, Element, documentToParentNode, elementToNode)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (Unit, bind, pure, ($), (<#>), (<>), (>>=))
import Unsafe.Coerce (unsafeCoerce)

unsafeFindElement :: forall e m. (MonadEff (dom :: DOM | e) m) => String -> m Element
unsafeFindElement queryStr = liftEff do
  doc <- getDocument
  maybeElem <- querySelector (QuerySelector queryStr) (documentToParentNode doc)
  case maybeElem of
    Nothing -> unsafeCrashWith $ "Element for query '" <> queryStr <> "' was not found."
    Just elem -> pure elem

getDocument :: forall e m. (MonadEff (dom :: DOM | e) m) => m Document
getDocument = liftEff $ window >>= document <#> htmlDocumentToDocument

createDomRoot :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
createDomRoot = liftEff do
  doc <- getDocument
  bdy <- unsafeFindElement "body"
  node <- createElement "div" doc
  child <- appendChild (elementToNode node) (elementToNode bdy)
  setAttribute "id" "app" (unsafeCoerce child)

afterAll :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
afterAll = liftEff do
  doc <- getDocument
  node <- createElement "div" doc
  bdy <- unsafeFindElement "body"
  setTextContent "" (unsafeCoerce bdy)

module Test.Helper (
    unsafeFindElement
  , createDomRoot
  , afterAll
  ) where

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent)
import DOM.Node.ParentNode (QuerySelector(QuerySelector), querySelector)
import DOM.Node.Types (Document, Element, documentToParentNode, elementToNode)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafeCrashWith)
import Prelude (Unit, bind, pure, ($), (<>))
import Unsafe.Coerce (unsafeCoerce)

unsafeFindElement :: forall e m. (MonadEff (dom :: DOM | e) m) => String -> m Element
unsafeFindElement queryStr = liftEff do
  doc <- getDocument
  maybeElem <- querySelector (QuerySelector queryStr) (documentToParentNode doc)
  case maybeElem of
    Nothing -> unsafeCrashWith $ "Element for query '" <> queryStr <> "' was not found."
    Just elem -> pure elem

getDocument :: forall e m. (MonadEff (dom :: DOM | e) m) => m Document
getDocument = liftEff do
  wndow <- window
  doc <- document wndow
  pure $ htmlDocumentToDocument doc

createDomRoot :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
createDomRoot = liftEff do
  doc <- getDocument
  bdy <- unsafeFindElement "body"
  node <- createElement "div" doc
  child <- appendChild (elementToNode node) (elementToNode bdy)
  setAttribute "id" "app" (unsafeCoerce child)

afterAll :: forall e m. (MonadEff (dom :: DOM | e) m) => m Unit
afterAll = liftEff do
  doc <- getDocument
  node <- createElement "div" doc
  bdy <- unsafeFindElement "body"
  setTextContent "" (unsafeCoerce bdy)