Remove Eff usage from router

Remove Eff usage from router

-- Highly experimental and naive implementation of servant-server style
-- routing for Hyper. Not much will be stable, nor usable, here.
module Hyper.Routing.TypeLevelRouter where

import Prelude
import Control.Monad.Error.Class (throwError)
import Data.Array (elem, filter, foldl, uncons)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Int (fromString)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Path.Pathy (dir, rootDir, (</>))
import Data.String (Pattern(..), split)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.URI (HierarchicalPart(..), URI(..))
import Type.Proxy (Proxy(..))

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

data Verb (m :: Symbol) (ct :: Symbol)

type Get ct = Verb "GET" ct

data Sub e t
data Endpoints a b = Endpoints a b

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

newtype Link = Link (Array String)

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

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

derive instance newtypeLink :: Newtype Link _

derive instance genericLink :: Generic Link _

instance eqLink :: Eq Link where
  eq = genericEq

linkToURI :: Link -> URI
linkToURI (Link segments) =
  URI
  Nothing
  (HierarchicalPart
   Nothing
   (Just (Left (foldl (</>) rootDir (map dir segments)))))
  Nothing
  Nothing

class ToHttpData x where
  toPathPiece :: x -> String

instance toHttpDataInt :: ToHttpData Int where
  toPathPiece = show

class FromHttpData x where
  fromPathPiece :: String -> Either String x

instance fromHttpDataInt :: FromHttpData Int where
  fromPathPiece s =
    case fromString s of
      Just n -> Right n
      Nothing -> Left ("Invalid Int: " <> s)

class HasLink e mk | e -> mk where
  toLink :: Proxy e -> Link -> mk

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

instance hasLinkCapture :: (HasLink sub subMk, IsSymbol c, ToHttpData t) => HasLink (Capture c t :> sub) (t -> subMk) where
  toLink _ l (x :: t) =
    toLink (Proxy :: Proxy sub) $ append l (Link [toPathPiece x])

instance hasLinkVerb :: HasLink (Verb m ct) URI where
  toLink _ = linkToURI

linkTo :: forall l t. HasLink l t => Proxy l -> t
linkTo p = toLink p mempty

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

data RoutingError
  = HTTPError Int (Maybe String)

derive instance genericRoutingError :: Generic RoutingError _

instance eqRoutingError :: Eq RoutingError where
  eq = genericEq

instance showRoutingError :: Show RoutingError where
  show = genericShow

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

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

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

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

instance hasRouterCapture :: (HasRouter e h out, FromHttpData v)
                             => HasRouter (Capture c v :> e) (v -> h) out where
  route _ ctx r =
    case uncons ctx.path of
      Nothing -> throwError (HTTPError 404 Nothing)
      Just { head, tail } ->
        case fromPathPiece head of
          Left err -> throwError (HTTPError 400 (Just err))
          Right x -> route (Proxy :: Proxy e) ctx { path = tail } (r x)

instance hasRouterVerb :: (IsSymbol m)
                          => HasRouter (Verb m ct) h h where
  route _ context r =
    if expectedMethod == context.method
    then pure r
    else throwError (HTTPError 405 (Just ("Method "
                                          <> context.method
                                          <> " did not match "
                                          <> expectedMethod)))
    where
      expectedMethod = reflectSymbol (SProxy :: SProxy m)

runRouter
  :: forall s r a.
     HasRouter s r a
     => Proxy s
     -> r
     -> String
     -> String
     -> Either RoutingError a
runRouter _ handler method url =
  route (Proxy :: Proxy s) { path: p, method: method } handler
  where
    p = filter ((/=) "") (split (Pattern "/") url)

-- Highly experimental and naive implementation of servant-server style
-- routing for Hyper. Not much will be stable, nor usable, here.
module Hyper.Routing.TypeLevelRouter where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Error.Class (throwError)
import Data.Array (elem, filter, foldl, uncons)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Int (fromString)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Path.Pathy (dir, rootDir, (</>))
import Data.String (Pattern(..), split)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.URI (HierarchicalPart(..), URI(..))
import Type.Proxy (Proxy(..))

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

data Verb (m :: Symbol) (ct :: Symbol)

type Get ct = Verb "GET" ct

data Sub e t
data Endpoints a b = Endpoints a b

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

newtype Link = Link (Array String)

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

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

derive instance newtypeLink :: Newtype Link _

derive instance genericLink :: Generic Link _

instance eqLink :: Eq Link where
  eq = genericEq

linkToURI :: Link -> URI
linkToURI (Link segments) =
  URI
  Nothing
  (HierarchicalPart
   Nothing
   (Just (Left (foldl (</>) rootDir (map dir segments)))))
  Nothing
  Nothing

class ToHttpData x where
  toPathPiece :: x -> String

instance toHttpDataInt :: ToHttpData Int where
  toPathPiece = show

class FromHttpData x where
  fromPathPiece :: String -> Either String x

instance fromHttpDataInt :: FromHttpData Int where
  fromPathPiece s =
    case fromString s of
      Just n -> Right n
      Nothing -> Left ("Invalid Int: " <> s)

class HasLink e mk | e -> mk where
  toLink :: Proxy e -> Link -> mk

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

instance hasLinkCapture :: (HasLink sub subMk, IsSymbol c, ToHttpData t) => HasLink (Capture c t :> sub) (t -> subMk) where
  toLink _ l (x :: t) =
    toLink (Proxy :: Proxy sub) $ append l (Link [toPathPiece x])

instance hasLinkVerb :: HasLink (Verb m ct) URI where
  toLink _ = linkToURI

linkTo :: forall l t. HasLink l t => Proxy l -> t
linkTo p = toLink p mempty

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

data RoutingError
  = HTTPError Int (Maybe String)

derive instance genericRoutingError :: Generic RoutingError _

instance eqRoutingError :: Eq RoutingError where
  eq = genericEq

instance showRoutingError :: Show RoutingError where
  show = genericShow

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

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

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

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

instance hasRouterCapture :: (HasRouter e h out, FromHttpData v)
                             => HasRouter (Capture c v :> e) (v -> h) out where
  route _ ctx r =
    case uncons ctx.path of
      Nothing -> throwError (HTTPError 404 Nothing)
      Just { head, tail } ->
        case fromPathPiece head of
          Left err -> throwError (HTTPError 400 (Just err))
          Right x -> route (Proxy :: Proxy e) ctx { path = tail } (r x)

instance hasRouterVerb :: (IsSymbol m)
                          => HasRouter (Verb m ct) h h where
  route _ context r =
    if expectedMethod == context.method
    then pure r
    else throwError (HTTPError 405 (Just ("Method "
                                          <> context.method
                                          <> " did not match "
                                          <> expectedMethod)))
    where
      expectedMethod = reflectSymbol (SProxy :: SProxy m)

runRouter
  :: forall s r e a.
     HasRouter s r (Eff e a)
     => Proxy s
     -> r
     -> String
     -> String
     -> Either RoutingError (Eff e a)
runRouter _ handler method url =
  route (Proxy :: Proxy s) { path: p, method: method } handler
  where
    p = filter ((/=) "") (split (Pattern "/") url)


Simplify error object property names

Simplify error object property names

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Error
-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Language.PureScript.Errors where

import Prelude.Unsafe (unsafeIndex)
import Data.Array
import qualified Data.Array.Unsafe as Unsafe
import Data.String (joinWith)
import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Monoid.Last
import Data.Foldable (mconcat)

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.Error.Proxy

import Language.PureScript.Pos
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Values
import Language.PureScript.Pretty.Types
import Language.PureScript.Types

-- |
-- Type for sources of type checking errors
--
data ErrorSource
  -- |
  -- An error which originated at a Value
  --
  = ValueError Value
  -- |
  -- An error which originated at a Type
  --
  | TypeError Type

instance showErrorSource :: Show ErrorSource where
  show (ValueError v) = "ValueError (" ++ show v ++ ")"
  show (TypeError t) = "TypeError (" ++ show t ++ ")"

-- |
-- Compilation errors
--
data CompileError = CompileError {
    -- |
    -- Error message
    --
    message :: String
    -- |
    -- The value where the error occurred
    --
  , value :: Maybe ErrorSource
    -- |
    -- Optional source position information
    --
  , position :: Maybe SourcePos
  }

mkCompileError :: String -> Maybe ErrorSource -> Maybe SourcePos -> CompileError
mkCompileError message value position =
  CompileError { message: message
	             , value: value
							 , position: position
							 }

instance showCompileError :: Show CompileError where
  show (CompileError o) = "CompileError {" ++
    "message: " ++  show o.message ++ ", " ++
    "value: " ++    show o.value ++ ", " ++
    "position: " ++ show o.position ++ " " ++
	  "}"

-- |
-- A stack trace for an error
--
data ErrorStack = ErrorStack [CompileError]

runErrorStack :: ErrorStack -> [CompileError]
runErrorStack (ErrorStack es) = es

instance showErrorStack :: Show ErrorStack where
  show (ErrorStack es) = "ErrorStack (" ++ show es ++ ")"

instance semigroupErrorStack :: Semigroup ErrorStack where
  (<>) (ErrorStack es1) (ErrorStack es2) = ErrorStack (es1 <> es2)

instance monoidErrorStack :: Monoid ErrorStack where
  mempty = ErrorStack []

instance errorErrorStack :: Error ErrorStack where
  strMsg s = ErrorStack [mkCompileError s Nothing Nothing]
  noMsg = ErrorStack []

unifyError :: WithErrorType ErrorStack
unifyError = WithErrorType

prettyPrintErrorStack :: Boolean -> ErrorStack -> String
prettyPrintErrorStack printFullStack (ErrorStack es) =
  case mconcat $ map (\(CompileError o) -> Last o.position) es of
    Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
    _ -> prettyPrintErrorStack'
  where

    prettyPrintErrorStack' :: String
    prettyPrintErrorStack' =
		  if printFullStack
	    then
		  	joinWith "\n" (map showError (filter isErrorNonEmpty es))
      else
		  	let
          es' = filter isErrorNonEmpty es
        in case length es' of
          1 -> showError (Unsafe.head es')
          _ -> showError (Unsafe.head es') ++ "\n" ++ showError (Unsafe.last es')

stringifyErrorStack :: forall a. Boolean -> Either ErrorStack a -> Either String a
stringifyErrorStack printFullStack = either (Left <<< prettyPrintErrorStack printFullStack) Right

isErrorNonEmpty :: CompileError -> Boolean
isErrorNonEmpty (CompileError { message = "" }) = false
isErrorNonEmpty _ = true

showError :: CompileError -> String
showError (CompileError { message = msg, value = Nothing }) = msg
showError (CompileError { message = msg, value = Just (ValueError val) }) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg
showError (CompileError { message = msg, value = Just (TypeError ty) }) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [mkCompileError msg t Nothing]

positionError :: SourcePos -> ErrorStack
positionError pos = ErrorStack [mkCompileError "" Nothing (Just pos)]

-- |
-- Rethrow an error with a more detailed error message in the case of failure
--
rethrow :: forall e m a. (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)

-- |
-- Rethrow an error with source position information
--
rethrowWithPosition :: forall m a. (MonadError ErrorStack m) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow ((<>) (positionError pos))

-- |
-- Throw a runtime error for a situation where something unexpected (and
-- supposedly impossible) happened
--
foreign import theImpossibleHappened
  "function theImpossibleHappened(msg) {\
  \  throw new Error(msg);\
  \}" :: forall a. String -> a

-- |
-- This is a hack to emulate the semantics of Haskell's "error" function.
-- It can only be used with types whose runtime representation is an Object.
--
foreign import error
  "function error(msg) {\
  \  var explode = function() {\
  \    this.__defineGetter__('ctor', function() {\
  \      throw new Error(msg);\
  \    });\
  \  };\
  \  return new explode();\
  \}" :: forall a. a

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Error
-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Language.PureScript.Errors where

import Prelude.Unsafe (unsafeIndex)
import Data.Array
import qualified Data.Array.Unsafe as Unsafe
import Data.String (joinWith)
import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Monoid.Last
import Data.Foldable (mconcat)

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.Error.Proxy

import Language.PureScript.Pos
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Values
import Language.PureScript.Pretty.Types
import Language.PureScript.Types

-- |
-- Type for sources of type checking errors
--
data ErrorSource
  -- |
  -- An error which originated at a Value
  --
  = ValueError Value
  -- |
  -- An error which originated at a Type
  --
  | TypeError Type

instance showErrorSource :: Show ErrorSource where
  show (ValueError v) = "ValueError (" ++ show v ++ ")"
  show (TypeError t) = "TypeError (" ++ show t ++ ")"

-- |
-- Compilation errors
--
data CompileError = CompileError {
    -- |
    -- Error message
    --
    compileErrorMessage :: String
    -- |
    -- The value where the error occurred
    --
  , compileErrorValue :: Maybe ErrorSource
    -- |
    -- Optional source position information
    --
  , compileErrorPosition :: Maybe SourcePos
  }

mkCompileError :: String -> Maybe ErrorSource -> Maybe SourcePos -> CompileError
mkCompileError compileErrorMessage compileErrorValue compileErrorPosition =
  CompileError { compileErrorMessage: compileErrorMessage
	             , compileErrorValue: compileErrorValue
							 , compileErrorPosition: compileErrorPosition
							 }

instance showCompileError :: Show CompileError where
  show (CompileError o) = "CompileError {" ++
    "compileErrorMessage: " ++  show o.compileErrorMessage ++ ", " ++
    "compileErrorValue: " ++    show o.compileErrorValue ++ ", " ++
    "compileErrorPosition: " ++ show o.compileErrorPosition ++ " " ++
	  "}"

-- |
-- A stack trace for an error
--
data ErrorStack = ErrorStack [CompileError]

runErrorStack :: ErrorStack -> [CompileError]
runErrorStack (ErrorStack es) = es

instance showErrorStack :: Show ErrorStack where
  show (ErrorStack es) = "ErrorStack (" ++ show es ++ ")"

instance semigroupErrorStack :: Semigroup ErrorStack where
  (<>) (ErrorStack es1) (ErrorStack es2) = ErrorStack (es1 <> es2)

instance monoidErrorStack :: Monoid ErrorStack where
  mempty = ErrorStack []

instance errorErrorStack :: Error ErrorStack where
  strMsg s = ErrorStack [mkCompileError s Nothing Nothing]
  noMsg = ErrorStack []

unifyError :: WithErrorType ErrorStack
unifyError = WithErrorType

prettyPrintErrorStack :: Boolean -> ErrorStack -> String
prettyPrintErrorStack printFullStack (ErrorStack es) =
  case mconcat $ map (\(CompileError o) -> Last o.compileErrorPosition) es of
    Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
    _ -> prettyPrintErrorStack'
  where

    prettyPrintErrorStack' :: String
    prettyPrintErrorStack' =
		  if printFullStack
	    then
		  	joinWith "\n" (map showError (filter isErrorNonEmpty es))
      else
		  	let
          es' = filter isErrorNonEmpty es
        in case length es' of
          1 -> showError (Unsafe.head es')
          _ -> showError (Unsafe.head es') ++ "\n" ++ showError (Unsafe.last es')

stringifyErrorStack :: forall a. Boolean -> Either ErrorStack a -> Either String a
stringifyErrorStack printFullStack = either (Left <<< prettyPrintErrorStack printFullStack) Right

isErrorNonEmpty :: CompileError -> Boolean
isErrorNonEmpty (CompileError { compileErrorMessage = "" }) = false
isErrorNonEmpty _ = true

showError :: CompileError -> String
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Nothing }) = msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (ValueError val) }) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (TypeError ty) }) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [mkCompileError msg t Nothing]

positionError :: SourcePos -> ErrorStack
positionError pos = ErrorStack [mkCompileError "" Nothing (Just pos)]

-- |
-- Rethrow an error with a more detailed error message in the case of failure
--
rethrow :: forall e m a. (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)

-- |
-- Rethrow an error with source position information
--
rethrowWithPosition :: forall m a. (MonadError ErrorStack m) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow ((<>) (positionError pos))

-- |
-- Throw a runtime error for a situation where something unexpected (and
-- supposedly impossible) happened
--
foreign import theImpossibleHappened
  "function theImpossibleHappened(msg) {\
  \  throw new Error(msg);\
  \}" :: forall a. String -> a

-- |
-- This is a hack to emulate the semantics of Haskell's "error" function.
-- It can only be used with types whose runtime representation is an Object.
--
foreign import error
  "function error(msg) {\
  \  var explode = function() {\
  \    this.__defineGetter__('ctor', function() {\
  \      throw new Error(msg);\
  \    });\
  \  };\
  \  return new explode();\
  \}" :: forall a. a


more strict types: `Free dsl (state -> state)`

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (Store state))
  -> Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect storeEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      store <- addReactDisallowedEff $ storeEff this
      state <- Redox.getState store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      store <- addReactEff $ storeEff this
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- addReactReadOnlyEff $ storeEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

    renderFn this = do
      props' <- R.getProps this
      state <- R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (_iso state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect storeEff _lns _iso cls
  where
    storeEff this = readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store

connect
  :: forall state state' props props'
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
connectStore
  :: forall state state' props props' eff
   . Store state
  -> Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store _lns _iso cls = _connect (const $ pure store) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy (RedoxContext state dsl (context :: CONTEXT | eff)) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (Store state))
  -> Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect storeEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      store <- addReactDisallowedEff $ storeEff this
      state <- Redox.getState store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      store <- addReactEff $ storeEff this
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- addReactReadOnlyEff $ storeEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

    renderFn this = do
      props' <- R.getProps this
      state <- R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (_iso state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state dsl eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect storeEff _lns _iso cls
  where
    storeEff this = readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store

connect
  :: forall state state' props props'
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
connectStore
  :: forall state state' props props' eff
   . Store state
  -> Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store _lns _iso cls = _connect (const $ pure store) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> dsl
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy (RedoxContext state dsl (context :: CONTEXT | eff)) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl


Add some multi-argument lifts.

Add some multi-argument lifts.

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , distinct'
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = seed;
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import distinctRefP """
  function distinctRefP(constant, sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (val !== newval) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  }""" :: forall a c. Fn2 (c -> Signal c) (Signal a) (Signal a)

distinct' :: forall a. Signal a -> Signal a
distinct' = runFn2 distinctRefP constant

foreign import zipP """
  function zipP(constant, f, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(f(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(f(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(f(val1)(val2));
    });
    return out;
  }""" :: forall a b c d. Fn4 (d -> Signal d) (a -> b -> c) (Signal a) (Signal b) (Signal c)

zip :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
zip f a b = runFn4 zipP constant f a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

lift2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
lift2 f a b = f <~ a ~ b

lift3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
lift3 f a b c = f <~ a ~ b ~ c

lift4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
lift4 f a b c d = f <~ a ~ b ~ c ~ d

lift5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
lift5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e


Improve scanner spec readability

Improve scanner spec readability

module Test.Spec.ScannerSpec (scannerSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Aff
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Bifunctor (lmap)
import Data.List (List(..), length, (!!), take)
import Data.TemplateString.Unsafe ((<~>))
import Data.Either (Either(..), isRight, isLeft, either, fromRight)
import Data.Either (fromRight)
import Data.Maybe (Maybe(..), fromJust)
import Data.String.Chalk as Chalk
import Data.String.Ext as String
import Data.String.Yarn (replicate) as String
import Text.Parsing.Parser (ParseError(..))
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.String as String
import Partial.Unsafe (unsafePartial)

import Language.Docopt
import Language.Docopt.Scanner as Scanner
import Text.Wrap (dedent)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runEitherEff)

scannerSpec = \_ ->
  describe "The scanner" do
    it "should scan sections" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan
            """
            Usage: foo
            Options: bar
            Advanced Options: qux
            """
        length options `shouldEq` 2
        usage                    =?= "%Usage:% foo"
        fromJust' (options !! 0) =?= "%Options:% bar"
        fromJust' (options !! 1) =?= "%Advanced Options:% qux"

    it "should scan sections with new line after colon" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan
            """
            Usage:
              foo
            Options:
              bar
            Advanced Options:
              qux
            """

        length options `shouldEq` 2
        usage =?=
          """
          %Usage:%
            foo
          """
        fromJust' (options !! 0) =?=
          """
          %Options:%
            bar
          """
        fromJust' (options !! 1) =?=
          """
          %Advanced Options:%
            qux
          """

    it "should ignore ascii escape codes" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan $ (Chalk.blue "Usage:") <> " foo\n"
        length options `shouldEq` 0
        usage =?= ("%" <> (Chalk.blue "Usage:") <> "% foo")

    it "should ignore ascii escape codes" do
      let usageHeader = Chalk.blue "Usage:"
      vliftEff do
        { usage, options } <- runEitherEff do
          scan $ dedent do
            """
            ${usageHeader}
              foo
            """ <~> { usageHeader: usageHeader }
        length options `shouldEq` 0
        usage =?=
          """
          %${usageHeader}%
            foo
          """ <~> { usageHeader: usageHeader }

    it "should fail w/o a usage section" do
      vliftEff do
        scan "Options: bar" `shouldFailWith` "No usage section found!"

    it "should fail w/o any sections" do
      vliftEff do
        scan "" `shouldFailWith` "No usage section found!"

scan = lmap getMessage <<< Scanner.scan <<< dedent

getMessage :: ParseError -> String
getMessage (ParseError m _ _) = m

shouldFailWith :: ∀ a. Either String a -> String -> Eff _ Unit
shouldFailWith ea msg = case ea of
                      Left m | m == msg -> pure unit
                      Right _           -> throwException $ error $
                                            "Expected failure:\n" <> msg
                      Left m            -> throwException $ error $
                                            "Unexpected error message:\n"
                                              <> m <> "\n"
                                              <> "Expected :\n"
                                              <> msg

shouldEq :: ∀ a. (Show a, Eq a) => a -> a -> Eff _ Unit
shouldEq a b = if a /= b
                  then
                    throwException $ error $
                      "Expected " <> show a <> " to equal " <> show b
                  else pure unit

shouldEqS :: String -> String -> Eff _ Unit
shouldEqS a = shouldEq a
  <<< stripInitialNewline
  <<< addTrailingNewline
  <<< replaceUnderScores
  <<< dedent
  <<< placeHoldersToUnderscores
  where
    placeHoldersToUnderscores = Regex.replace'
      (regex' "%[^%]+%" "g")
      (\m _ -> String.replicate (String.length m - 2) '_')
    replaceUnderScores    = Regex.replace (regex' "_" "g") " "
    addTrailingNewline s  = if String.endsWith "\n" s then s else s <> "\n"
    stripInitialNewline s = if String.startsWith "\n" s then String.drop 1 s else s
    regex' a b = unsafePartial $ fromRight $ regex a (Regex.parseFlags b)

fromJust' :: ∀ a. Maybe a -> a
fromJust' ma = unsafePartial $ fromJust ma

infixl 0 shouldEqS as =?=

module Test.Spec.ScannerSpec (scannerSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Aff
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Bifunctor (lmap)
import Data.List (List(..), length, (!!), take)
import Data.TemplateString.Unsafe ((<~>))
import Data.Either (Either(..), isRight, isLeft, either, fromRight)
import Data.Either (fromRight)
import Data.Maybe (Maybe(..), fromJust)
import Data.String.Chalk as Chalk
import Data.String.Ext as String
import Text.Parsing.Parser (ParseError(..))
import Data.String.Regex as Regex
import Data.String.Regex (regex, Regex())
import Data.String as String
import Partial.Unsafe (unsafePartial)

import Language.Docopt
import Language.Docopt.Scanner as Scanner
import Text.Wrap (dedent)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runEitherEff)

scannerSpec = \_ ->
  describe "The scanner" do
    it "should scan sections" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan
            """
            Usage: foo
            Options: bar
            Advanced Options: qux
            """
        length options `shouldEq` 2
        usage                    =?= "______ foo"
        fromJust' (options !! 0) =?= "________ bar"
        fromJust' (options !! 1) =?= "_________________ qux"

    it "should scan sections with new line after colon" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan
            """
            Usage:
              foo
            Options:
              bar
            Advanced Options:
              qux
            """

        length options `shouldEq` 2
        usage =?=
          """
          ______
          __foo
          """
        fromJust' (options !! 0) =?=
          """
          ________
          __bar
          """
        fromJust' (options !! 1) =?=
          """
          _________________
          __qux
          """

    it "should ignore ascii escape codes" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan do
            (Chalk.blue "Usage:")
              <> " foo"
              <> "\n"
        length options `shouldEq` 0
        usage =?= "_________________foo\n"

    it "should ignore ascii escape codes" do
      vliftEff do
        { usage, options } <- runEitherEff do
          scan $ dedent do
            """
            ${usageHeader}
              foo
            """ <~> {
              usageHeader: Chalk.blue "Usage:"
            }
        length options `shouldEq` 0
        usage =?=
          """
          ________________
          __foo
          """

    it "should fail w/o a usage section" do
      vliftEff do
        scan "Options: bar" `shouldFailWith` "No usage section found!"

    it "should fail w/o any sections" do
      vliftEff do
        scan "" `shouldFailWith` "No usage section found!"

scan = lmap getMessage <<< Scanner.scan <<< dedent

getMessage :: ParseError -> String
getMessage (ParseError m _ _) = m

shouldFailWith :: ∀ a. Either String a -> String -> Eff _ Unit
shouldFailWith ea msg = case ea of
                      Left m | m == msg -> pure unit
                      Right _           -> throwException $ error $
                                            "Expected failure:\n" <> msg
                      Left m            -> throwException $ error $
                                            "Unexpected error message:\n"
                                              <> m <> "\n"
                                              <> "Expected :\n"
                                              <> msg

shouldEq :: ∀ a. (Show a, Eq a) => a -> a -> Eff _ Unit
shouldEq a b = if a /= b
                  then
                    throwException $ error $
                      "Expected " <> show a <> " to equal " <> show b
                  else pure unit

shouldEqS :: String -> String -> Eff _ Unit
shouldEqS a b = shouldEq a
  $ addTrailingNewline  -- ensure trailing '\n'
  $ stripInitialNewline -- remove leading '\n'
  $ Regex.replace       -- replace all '_' with ' '
      (unsafePartial $ fromRight $ regex "_" $ Regex.parseFlags "g")
      " "
      (dedent b)
  where
    stripInitialNewline s =
          if String.startsWith "\n" s
              then String.drop 1 s
              else s
    addTrailingNewline s =
          if String.endsWith "\n" s
              then s
              else s <> "\n"

fromJust' :: ∀ a. Maybe a -> a
fromJust' ma = unsafePartial $ fromJust ma

infixl 0 shouldEqS as =?=


aw yeah, show me some more data

aw yeah, show me some more data

module FrontEnd where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (error)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import Control.MonadPlus (guard)
import DOM (DOM)
import DOM.HTML.Types (readHTMLElement)
import Data.Array (filter, group', intercalate, length, reverse, sort, sortWith)
import Data.Date (Date)
import Data.DateTime (adjust, date)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..), either)
import Data.Foreign (ForeignError)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.Int (ceil, toNumber)
import Data.JSDate as JSDate
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, isNothing, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.NonEmpty (NonEmpty, head, oneOf)
import Data.Number.Format (toString)
import Data.String (Pattern(..), contains, split, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Time.Duration (Days(..))
import Data.Traversable (find, traverse_)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import ECharts.Chart as EC
import ECharts.Commands as E
import ECharts.Monad as EM
import ECharts.Types as ET
import ECharts.Types.Phantom as ETP
import Global.Unsafe (unsafeStringify)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as AJ
import Routes (Route(..), files, open, update, watched)
import Types (FileData(..), OpenRequest(..), Path(..), WatchedData(..))

type VE a = V (NonEmptyList ForeignError) a

request :: forall req res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => Encode req
  => Decode res
  => IsSymbol url
  => Route req res url -> Maybe req -> m (VE res)
request (Route route) body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left route.method
      , url = reflectSymbol (SProxy :: SProxy url)
      , content = unsafeStringify <<< encode <$> body
      }
    parseResponse response =
      runExcept $ decodeJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , chart :: Maybe ET.Chart
  }

data Query a
  = Init a
  | FetchData a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter Path a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  , dom :: DOM
  , echarts :: ET.ECHARTS
  , exception :: EXCEPTION
  , now :: NOW
  | eff )

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , chart: Nothing
      }

    render :: State -> H.ComponentHTML Query
    render state =
      HH.div
        [ HP.class_ $ wrap "container" ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.div
            [ HP.ref $ wrap "heatmap"
            , HP.class_ $ wrap "heatmap"]
            []
        refreshButton =
          HH.button
            [ HP.classes $ wrap <$>
              [ "refresh-files"
              , "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        filterCheckbox =
          HH.button
            [ HP.classes $ wrap <$>
              [ "filter-watched"
              , "pure-button"
              ] <> (guard state.filterWatched $> "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div
            [ HP.class_ $ wrap "search" ]
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.h3
              [ HP.class_ $ wrap "file-link"
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ wrap "file-button"
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ wrap "file-note"] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ wrap "filter-link"
              ] [ HH.text "" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applySearchFiltering <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then filter $ isNothing <<< findWatched
          else id
        applySearchFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then id
            else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.a
              [ HP.classes $ wrap <$>
                [ "file-link"
                , maybe "" (const "watched") watched
                ]
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "file-button"
                , "pure-button"
                , maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ wrap "file-note" ]
              [ HH.text $ maybe "" id watched ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "filter-link"
                , "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter path)
              ]
              [ HH.text "set filter" ]
            ]
          where
            watched = getDate <$> findWatched path
            getDate (WatchedData {created}) =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    error' = H.liftEff <<< error

    updateChart' w = do
      chart <- H.gets _.chart
      case chart of
        Just ch -> do
          now <- toDateTime <$> H.liftEff now
          case date <$> adjust (Days (-120.0)) now of
            Just back -> H.liftEff $ EC.setOption (options back (date now) series) ch
            Nothing -> error' "oops, we messed up dates"
        Nothing -> error' "wtf no chart???"
      where
        series = ChartSeries $ makeData <$> group' (extractMonth <$> w)
        makeData :: NonEmpty Array String -> ChartSeriesData
        makeData xs = ChartSeriesData { date: head xs, value: length $ oneOf xs }
        extractMonth :: WatchedData -> String
        extractMonth (WatchedData {created}) =
           unsafePerformEff <<< (prepareDateString <=< JSDate.parse) $ created
        prepareDateString jsdate = do
          year <- toString <$> JSDate.getFullYear jsdate
          month <- show <$> (+) 1 <<< ceil <$> JSDate.getMonth jsdate
          date <- toString <$> JSDate.getDate jsdate
          pure $ intercalate "-" [year, month, date]

    eval :: Query ~> H.ComponentDSL State Query Void (AppEffects eff)
    eval (Init next) = do
      heatmap <- H.getRef (wrap "heatmap")
      case runExcept <<< readHTMLElement <$> heatmap of
        Just (Right el) -> do
          chart <- H.liftEff $ EC.init el
          H.modify _ {chart = Just chart}
        _ -> error' "can't find heatmap element?"
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unV'
        \(Tuple f w) -> do
          H.modify _ {files = f, watched = w}
          updateChart' w
      pure next
      where
        getResult = do
          files <- request files Nothing
          watched <- request watched Nothing
          pure $ Tuple <$> files <*> watched

    eval (OpenFile path next) = do
      _ <- request open $ Just (OpenRequest {path})
      pure next

    eval (SetWatched path flag next) = do
      request update (Just $ FileData {path, watched: flag}) >>= unV'
        \w -> do
          H.modify _ {watched = w}
          updateChart' w
      pure next

    eval (Filter path next) = do
      case extract path of
        Left e -> error' e *> pure next
        Right s -> eval $ Search s next
      where
        extract (Path s)
          | [_, a] <- split (Pattern "] ") s
          , [b, _] <- split (Pattern " -") a = Right b
          | otherwise = Left "didn't match expected patterns"

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify _ {filterWatched = flag}
      pure next

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    , now :: NOW
    , echarts :: ET.ECHARTS
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"

options :: Date -> Date -> ChartSeries -> EM.DSL ETP.OptionI
options a b (ChartSeries xs) = do
  E.tooltip do
    E.positionTop
  E.visualMap $ E.continuous do
    E.min 0.0
    E.max 10.0
    E.calculable true
    E.orient ET.Horizontal
    E.leftCenter
    E.topTop
  E.calendar do
    E.calendarSpec do
      E.buildRange do
        E.addDateValue $ a
        E.addDateValue $ b
      E.buildCellSize do
        E.autoValue
        E.autoValue
  E.series do
    E.heatMap do
      E.calendarCoordinateSystem
      E.calendarIndex 0
      E.buildItems
        $ traverse_ E.addItem (pair <$> xs)
  where
    pair (ChartSeriesData {date, value}) = do
      E.buildValues do
        E.addStringValue date
        E.addValue $ toNumber value

module FrontEnd where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (error)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import Control.MonadPlus (guard)
import DOM (DOM)
import DOM.HTML.Types (readHTMLElement)
import Data.Array (filter, group', intercalate, length, reverse, sort, sortWith)
import Data.Date (Date)
import Data.DateTime (adjust, date)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..), either)
import Data.Foreign (ForeignError)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.Int (ceil, toNumber)
import Data.JSDate as JSDate
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, isNothing, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.NonEmpty (NonEmpty, head, oneOf)
import Data.Number.Format (toString)
import Data.String (Pattern(..), contains, split, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Time.Duration (Days(..))
import Data.Traversable (find, traverse_)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import ECharts.Chart as EC
import ECharts.Commands as E
import ECharts.Monad as EM
import ECharts.Types as ET
import ECharts.Types.Phantom as ETP
import Global.Unsafe (unsafeStringify)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as AJ
import Routes (Route(..), files, open, update, watched)
import Types (FileData(..), OpenRequest(..), Path(..), WatchedData(..))

type VE a = V (NonEmptyList ForeignError) a

request :: forall req res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => Encode req
  => Decode res
  => IsSymbol url
  => Route req res url -> Maybe req -> m (VE res)
request (Route route) body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left route.method
      , url = reflectSymbol (SProxy :: SProxy url)
      , content = unsafeStringify <<< encode <$> body
      }
    parseResponse response =
      runExcept $ decodeJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , chart :: Maybe ET.Chart
  }

data Query a
  = Init a
  | FetchData a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter Path a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  , dom :: DOM
  , echarts :: ET.ECHARTS
  , exception :: EXCEPTION
  , now :: NOW
  | eff )

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , chart: Nothing
      }

    render :: State -> H.ComponentHTML Query
    render state =
      HH.div
        [ HP.class_ $ wrap "container" ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.div
            [ HP.ref $ wrap "heatmap"
            , HP.class_ $ wrap "heatmap"]
            []
        refreshButton =
          HH.button
            [ HP.classes $ wrap <$>
              [ "refresh-files"
              , "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        filterCheckbox =
          HH.button
            [ HP.classes $ wrap <$>
              [ "filter-watched"
              , "pure-button"
              ] <> (guard state.filterWatched $> "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div
            [ HP.class_ $ wrap "search" ]
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.h3
              [ HP.class_ $ wrap "file-link"
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ wrap "file-button"
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ wrap "file-note"] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ wrap "filter-link"
              ] [ HH.text "" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applySearchFiltering <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then filter $ isNothing <<< findWatched
          else id
        applySearchFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then id
            else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ wrap "file"]
            [ HH.a
              [ HP.classes $ wrap <$>
                [ "file-link"
                , maybe "" (const "watched") watched
                ]
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "file-button"
                , "pure-button"
                , maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ wrap "file-note" ]
              [ HH.text $ maybe "" id watched ]
            , HH.button
              [ HP.classes $ wrap <$>
                [ "filter-link"
                , "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter path)
              ]
              [ HH.text "set filter" ]
            ]
          where
            watched = getDate <$> findWatched path
            getDate (WatchedData {created}) =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    error' = H.liftEff <<< error

    updateChart' w = do
      chart <- H.gets _.chart
      case chart of
        Just ch -> do
          now <- toDateTime <$> H.liftEff now
          case date <$> adjust (Days (-90.0)) now of
            Just back -> H.liftEff $ EC.setOption (options back (date now) series) ch
            Nothing -> error' "oops, we messed up dates"
        Nothing -> error' "wtf no chart???"
      where
        series = ChartSeries $ makeData <$> group' (extractMonth <$> w)
        makeData :: NonEmpty Array String -> ChartSeriesData
        makeData xs = ChartSeriesData { date: head xs, value: length $ oneOf xs }
        extractMonth :: WatchedData -> String
        extractMonth (WatchedData {created}) =
           unsafePerformEff <<< (prepareDateString <=< JSDate.parse) $ created
        prepareDateString jsdate = do
          year <- toString <$> JSDate.getFullYear jsdate
          month <- show <$> (+) 1 <<< ceil <$> JSDate.getMonth jsdate
          date <- toString <$> JSDate.getDate jsdate
          pure $ intercalate "-" [year, month, date]

    eval :: Query ~> H.ComponentDSL State Query Void (AppEffects eff)
    eval (Init next) = do
      heatmap <- H.getRef (wrap "heatmap")
      case runExcept <<< readHTMLElement <$> heatmap of
        Just (Right el) -> do
          chart <- H.liftEff $ EC.init el
          H.modify _ {chart = Just chart}
        _ -> error' "can't find heatmap element?"
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unV'
        \(Tuple f w) -> do
          H.modify _ {files = f, watched = w}
          updateChart' w
      pure next
      where
        getResult = do
          files <- request files Nothing
          watched <- request watched Nothing
          pure $ Tuple <$> files <*> watched

    eval (OpenFile path next) = do
      _ <- request open $ Just (OpenRequest {path})
      pure next

    eval (SetWatched path flag next) = do
      request update (Just $ FileData {path, watched: flag}) >>= unV'
        \w -> do
          H.modify _ {watched = w}
          updateChart' w
      pure next

    eval (Filter path next) = do
      case extract path of
        Left e -> error' e *> pure next
        Right s -> eval $ Search s next
      where
        extract (Path s)
          | [_, a] <- split (Pattern "] ") s
          , [b, _] <- split (Pattern " -") a = Right b
          | otherwise = Left "didn't match expected patterns"

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify _ {filterWatched = flag}
      pure next

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    , now :: NOW
    , echarts :: ET.ECHARTS
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"

options :: Date -> Date -> ChartSeries -> EM.DSL ETP.OptionI
options a b (ChartSeries xs) = do
  E.tooltip do
    E.positionTop
  E.visualMap $ E.continuous do
    E.min 0.0
    E.max 10.0
    E.calculable true
    E.orient ET.Horizontal
    E.leftCenter
    E.topTop
  E.calendar do
    E.calendarSpec do
      E.buildRange do
        E.addDateValue $ a
        E.addDateValue $ b
      E.buildCellSize do
        E.autoValue
        E.autoValue
  E.series do
    E.heatMap do
      E.calendarCoordinateSystem
      E.calendarIndex 0
      E.buildItems
        $ traverse_ E.addItem (pair <$> xs)
  where
    pair (ChartSeriesData {date, value}) = do
      E.buildValues do
        E.addStringValue date
        E.addValue $ toNumber value


Improved types for render function

Improved types for render function

module Mustache where

import Data.StrMap
import Prelude

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> View -> Partials -> String

foreign import escape :: String -> String

module Mustache where

import Data.StrMap
import Prelude

type Template = String

type Tag = String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> StrMap String -> StrMap String

foreign import escape :: String -> String


Update example for 0.12

Update example for 0.12

module Main where

import Prelude

import Cherry (mount)
import Cherry.Renderer as R
import Cherry.Router (router, navigateTo, goBack)
import Cherry.Router.Parser (match, lit, int, end)
import Cherry.Store as S
import Cherry.Style (getStyle)
import Cherry.VDOM (VNode, h, t, targetValue, (:=), (~>))
import Control.Alt ((<|>))
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Effect (Effect)
import Effect.Aff (launchAff, delay)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Style (sheet, link)
import Web.Event.Event (Event)

-- Initialize app
main :: Effect Unit
main = do
  renderer <- R.createRenderer "#app" view
  mount store renderer [ route ]

-- Initialize core

store :: S.Store State
store = S.createStore initialState

select :: forall a. (State -> a) -> Effect a
select = S.select store

reduce :: (State -> State) -> Effect Unit
reduce = S.reduce store

-- Router

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: Effect Unit
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- View

view :: State -> VNode
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: VNode
style = h "style" [] [ t styleStr ]
  where
    styleStr = getStyle sheet

home :: String -> VNode
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> changeMessage
        ]
        []
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: Int -> Int -> VNode
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> const increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> const goBack ] [ t "Back" ]
    ]

notFound :: VNode
notFound =
  h "div" []
    [ h "h1" [ "style" := "color: red;" ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry", "target" := "_blank" ] [ t "Github" ]
    ]

-- Action

increment :: Effect Unit
increment = do
  _ <- launchAff $ do
    delay $ Milliseconds 1500.0
    liftEffect $ reduce incr
  pure unit

changeMessage :: Event -> Effect Unit
changeMessage ev = do
  content <- targetValue ev
  reduce $ updateMsg content
  cnt <- select _.count
  reduce \s -> s { count = cnt + 1 }
  log "bar"

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }

module Main where

import Prelude

import Cherry (mount)
import Cherry.Renderer as R
import Cherry.Router (router, navigateTo, goBack)
import Cherry.Router.Parser (match, lit, int, end)
import Cherry.Store as S
import Cherry.Style (getStyle)
import Cherry.VDOM (VNode, h, t, targetValue, (:=), (~>))
import Control.Alt ((<|>))
import Control.Monad.Aff (liftEff', launchAff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import DOM (DOM)
import DOM.Event.Event (Event)
import DOM.HTML.Types (HISTORY)
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Style (sheet, link)

-- Initialize app
main :: Eff (dom :: DOM, console :: CONSOLE, ref :: REF, exception :: EXCEPTION, history :: HISTORY) Unit
main = do
  renderer <- R.createRenderer "#app" view
  mount store renderer [ route ]

-- Initialize core

store :: forall e. S.Store (ref :: REF | e) State
store = S.createStore initialState

select :: forall e a. (State -> a) -> Eff (ref :: REF | e) a
select = S.select store

reduce :: forall e. (State -> State) -> Eff (ref :: REF | e) Unit
reduce = S.reduce store

-- Router

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: forall e. Eff (dom :: DOM, ref :: REF | e) Unit
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- View

view :: forall e. State -> VNode (exception :: EXCEPTION, dom :: DOM, history :: HISTORY, ref :: REF, console :: CONSOLE | e)
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: forall e. VNode e
style = h "style" [] [ t styleStr ]
  where
    styleStr = getStyle sheet

home :: forall e. String -> VNode (dom :: DOM, console :: CONSOLE, ref :: REF, history :: HISTORY | e)
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> changeMessage
        ]
        []
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link, "onClick" ~> (const $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: forall e. Int -> Int -> VNode (dom :: DOM, exception :: EXCEPTION, ref :: REF, history :: HISTORY | e)
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> const increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> const goBack ] [ t "Back" ]
    ]

notFound :: forall e. VNode e
notFound =
  h "div" []
    [ h "h1" [ "style" := "color: red;" ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry", "target" := "_blank" ] [ t "Github" ]
    ]

-- Action

increment :: forall e. Eff (ref :: REF, exception :: EXCEPTION | e) Unit
increment = do
  _ <- launchAff $ do
    delay $ Milliseconds 1500.0
    liftEff' $ reduce incr
  pure unit

changeMessage :: forall e. Event -> Eff (console :: CONSOLE, dom :: DOM, ref :: REF | e) Unit
changeMessage ev = do
  content <- targetValue ev
  reduce $ updateMsg content
  cnt <- select _.count
  reduce \s -> s { count = cnt + 1 }
  log "bar"

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }


Publicize parseArgsForeign

Publicize parseArgsForeign

module Minimist
    ( Arg(..)
    , MinimistOptions
    , interpretAsStrings
    , interpretAsBooleans
    , aliases
    , defaults
    , stopEarly
    , splitOnDoubleDash
    , unknown
    , parseArgs
    , parseArgsForeign
    ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, fromRight)
import Data.Foreign (Foreign, toForeign, unsafeFromForeign)
import Data.Foreign.Class (class AsForeign, class IsForeign, read, write)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

-- | Phantom data type of options for the minimist parser
data MinimistOptions

-- | Array of strings to always be interpreted as strings
interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

-- | Array of strings to always be interpreted as booleans
-- | or a boolean value indicating that all options starting
-- | with `--` that don't contain an equals sign should be
-- | interpreted as booleans
interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< either toForeign toForeign

-- | Mapping of strings to a list of aliases for that option
aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

-- | Mapping of strings to default argument values
defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) write

-- | When `true`, argument parsing will stop at the first non-flag
stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

-- | When `true`, all options appearing after `--` will be placed
-- | into `--` instead of `_` in the result mapping
splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

-- | Function to be called with every argument not found in the
-- | configuration object. If the function retruns false, then the
-- | argument is not added to argv.
unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> Foreign

-- | Data type representing the value of an argument in `argv`
data Arg = ArgString String
         | ArgFlag Boolean
         | ArgInt Int
         | ArgNum Number
         | ArgArray (Array Arg)

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgFlag flag) = show flag
    show (ArgInt i) = show i
    show (ArgNum n) = show n
    show (ArgArray a) = show a

instance argIsForeign :: IsForeign Arg where
    read value =
        (ArgString <$> read value) <|>
        (ArgFlag <$> read value) <|>
        (ArgInt <$> read value) <|>
        (ArgNum <$> read value) <|>
        (ArgArray <$> read value)

instance argAsForeign :: AsForeign Arg where
    write (ArgString s) = write s
    write (ArgFlag b) = write b
    write (ArgInt i) = write i
    write (ArgNum n) = write n
    write (ArgArray a) = write a

-- | Parse arguments with a set of minimist options into an `argv` representation,
-- | mapping argument names to `Arg` values.
parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = foreignToArg <$> (unsafeFromForeign $ parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)

module Minimist
    ( Arg(..)
    , MinimistOptions
    , interpretAsStrings
    , interpretAsBooleans
    , aliases
    , defaults
    , stopEarly
    , splitOnDoubleDash
    , unknown
    , parseArgs
    ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, fromRight)
import Data.Foreign (Foreign, toForeign, unsafeFromForeign)
import Data.Foreign.Class (class AsForeign, class IsForeign, read, write)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

-- | Phantom data type of options for the minimist parser
data MinimistOptions

-- | Array of strings to always be interpreted as strings
interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

-- | Array of strings to always be interpreted as booleans
-- | or a boolean value indicating that all options starting
-- | with `--` that don't contain an equals sign should be
-- | interpreted as booleans
interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< either toForeign toForeign

-- | Mapping of strings to a list of aliases for that option
aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

-- | Mapping of strings to default argument values
defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) write

-- | When `true`, argument parsing will stop at the first non-flag
stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

-- | When `true`, all options appearing after `--` will be placed
-- | into `--` instead of `_` in the result mapping
splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

-- | Function to be called with every argument not found in the
-- | configuration object. If the function retruns false, then the
-- | argument is not added to argv.
unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> Foreign

-- | Data type representing the value of an argument in `argv`
data Arg = ArgString String
         | ArgFlag Boolean
         | ArgInt Int
         | ArgNum Number
         | ArgArray (Array Arg)

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgFlag flag) = show flag
    show (ArgInt i) = show i
    show (ArgNum n) = show n
    show (ArgArray a) = show a

instance argIsForeign :: IsForeign Arg where
    read value =
        (ArgString <$> read value) <|>
        (ArgFlag <$> read value) <|>
        (ArgInt <$> read value) <|>
        (ArgNum <$> read value) <|>
        (ArgArray <$> read value)

instance argAsForeign :: AsForeign Arg where
    write (ArgString s) = write s
    write (ArgFlag b) = write b
    write (ArgInt i) = write i
    write (ArgNum n) = write n
    write (ArgArray a) = write a

-- | Parse arguments with a set of minimist options into an `argv` representation,
-- | mapping argument names to `Arg` values.
parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = foreignToArg <$> (unsafeFromForeign $ parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)


remove excessive white space

remove excessive white space

module Data.WikiText.Parsing.Parser (

  WikiTextParser(..),
  wikiText

) where

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Expr
import Text.Parsing.Parser.Token

import Control.Apply
import Control.Plus
import Control.Alt

import Data.WikiText.LinkTarget
import Data.WikiText.TextFormat
import Data.WikiText.Tokens
import Data.WikiText
import qualified Data.WikiText.Util.Array as Array
import qualified Data.Array as Array

import qualified Data.Maybe as Maybe

type WikiTextParser a = Parser [WikiToken] a

wikiText :: WikiTextParser [WikiText]
wikiText = syntax `manyTill` match EndOfInput

syntax :: WikiTextParser WikiText
syntax = heading
     <|> paragraph
     <|> fail "unsupported token"

--
-- A paragraph is made up of more text atom.
--
paragraph :: WikiTextParser WikiText
paragraph = Paragraph <$> anyText `many1Till` delimiter where
  delimiter = match Linebreak <|> lookAhead (match EndOfInput)

heading :: WikiTextParser WikiText
heading = try (nextType LinebreakType) *> do
  size <- getHeadingDelimiter
  text <- textTillHeadingOf size
  pure (Heading size text)

    where

    getHeadingDelimiter = ambigiousDelimiter HeadingType >>= getSize where
      getSize (DeHeading size) = pure size

    textTillHeadingOf size = anyText `manyTill` delimiter where
      delimiter = match (AmbigiousDelimiter (DeHeading size))

--
-- atoms
--

anyText :: WikiTextParser WikiAtom
anyText = choices <?> "any text" where

  choices = wordAtom
        <|> formatAtom
        <|> linkAtom
        <|> fail "unsupported word atom"

  wordAtom :: WikiTextParser WikiAtom
  wordAtom = wordParser <?> "word" where
    wordParser = tokenToSyntax <$> try (skipSpace (nextType WordType))
    tokenToSyntax (Word text) = (WordAtom text)

  formatAtom :: WikiTextParser WikiAtom
  formatAtom = formatParser <?> "format text" where

    formatParser = do
      style <- getFormatDelimiter
      text  <- textTillStyleOf style
      pure (FormatAtom style text)

    getFormatDelimiter = try delimiterParser >>= getType where
      delimiterParser = (skipSpace (ambigiousDelimiter FormatType))
      getType (DeFormat style) = pure style

    textTillStyleOf style = anyText `manyTill` delimiter where
      delimiter = match (AmbigiousDelimiter (DeFormat style))

  --
  -- internal link             [[hello]]
  -- internal link with text   [[hello|Greetings]]
  -- external link             [[[hello]]]
  -- external link with text   [[[hello|Greetings]]]
  --
  linkAtom :: WikiTextParser WikiAtom
  linkAtom = textLink Internal <|> textLink External where

    textLink target = try (openingDelimiter linkDelimiter) *> do
      destination <- word <?> "link destination"
      linkLabel   <- label <?> "text label"
      pure (HyperTextAtom target destination linkLabel) where

      linkDelimiter :: Delimiter
      linkDelimiter = targetToDelimiter target

      label :: WikiTextParser (Maybe.Maybe [WikiAtom])
      label = optionMaybe (try (pipe *> body)) <* closer where
        closer = closingDelimiter linkDelimiter
        body = skipSpace (anyText `manyTill` lookAhead closer)
        pipe = skipSpace (nextType PipeType)

    word :: WikiTextParser String
    word = toString <$> try (skipSpace (nextType WordType)) where
      toString (Word w) = w

--
-- -- predicates
--

data AmbigiousDelimiterType
  = HeadingType
  | FormatType

instance eqAmbigiousDelimiterType :: Eq AmbigiousDelimiterType where
  (/=) l r = not (l == r)
  (==) HeadingType HeadingType = true
  (==) FormatType FormatType = true
  (==) _ _ = false

ambigiousDelimiter :: AmbigiousDelimiterType -> WikiTextParser AmbigiousDelimiter
ambigiousDelimiter tokenType = nextType ADelimiterType >>= impl where

  impl (AmbigiousDelimiter token@(DeHeading _)) | tokenType == HeadingType = pure token
  impl (AmbigiousDelimiter token@(DeFormat _))  | tokenType == FormatType = pure token
  impl e = fail ("somehow " ++ show e ++ " was passed to ambigiousDelimiter")

openingDelimiter :: Delimiter -> WikiTextParser Delimiter
openingDelimiter delimterType = nextType ODelimiterType >>= impl where
  impl (OpeningDelimiter delimiter)
    | delimterType == delimiter = pure delimiter
    | otherwise                 = empty
  impl e = fail ("somehow " ++ show e ++ " was passed to openingDelimiter")

closingDelimiter :: Delimiter -> WikiTextParser Delimiter
closingDelimiter delimterType = nextType CDelimiterType >>= impl where
  impl (ClosingDelimiter delimiter)
    | delimterType == delimiter = pure delimiter
    | otherwise                 = empty
  impl e = fail ("somehow " ++ show e ++ " was passed to openingDelimiter")

--
-- -- methods
--

data TokenType
  = ODelimiterType
  | CDelimiterType
  | ADelimiterType
  | WordType
  | SpaceType
  | LinebreakType
  | EndOfInputType
  | PipeType

instance eqTokenType :: Eq TokenType where
  (/=) l r = not (l == r)

  (==) ODelimiterType ODelimiterType = true
  (==) CDelimiterType CDelimiterType = true
  (==) ADelimiterType ADelimiterType = true
  (==) WordType WordType = true
  (==) SpaceType SpaceType = true
  (==) LinebreakType LinebreakType = true
  (==) EndOfInputType EndOfInputType = true
  (==) PipeType PipeType = true
  (==) _ _ = false

--
-- a more general match so we can match on the type of token
-- as opposed to the exact value of the token.
--
nextType :: TokenType -> WikiTextParser WikiToken
nextType tokenType = token >>= matchType where

  matchType token@(Word _) | tokenType == WordType = pure token
  matchType token@(Space)  | tokenType == SpaceType = pure token
  matchType token@(Pipe)   | tokenType == PipeType = pure token

  matchType token@(EndOfInput) | tokenType == EndOfInputType = pure token
  matchType token@(Linebreak)  | tokenType == LinebreakType = pure token

  matchType token@(AmbigiousDelimiter _) | tokenType == ADelimiterType = pure token
  matchType token@(OpeningDelimiter _)   | tokenType == ODelimiterType = pure token
  matchType token@(ClosingDelimiter _)   | tokenType == CDelimiterType = pure token

  matchType (Ambigious choices) = firstMatch choices where
    firstMatch (x:xs) = matchType x <|> firstMatch xs
    firstMatch []     = empty

  matchType _ = empty

skipSpace :: forall a. WikiTextParser a -> WikiTextParser a
skipSpace parser = skipMany (match Space) *> parser

--
-- -- low level methods
--
--
-- takeWhile :: (WikiToken -> Boolean) -> DocParser [WikiToken]
-- takeWhile predicate = lift State.get >>= impl where
--   impl state = withTokens [] state.tokens where
--     withTokens acc tokens = do
--       split <- nothingError (Intern RanOutOfTokens) (Array.splitStart tokens)
--       if predicate split.head
--         then withTokens (acc ++ [split.head]) split.tail
--         else do
--           State.put (state { tokens = tokens })
--           pure acc
--
--
-- popToken :: DocParser WikiToken
-- popToken = do
--   state <- lift State.get
--   split <- nothingError (Intern RanOutOfTokens) (Array.splitStart state.tokens)
--   State.put (state { tokens = split.tail })
--   pure split.head
--
--
-- -- util
--
--
-- nothingError :: forall a e m. (Applicative m, Error.MonadError e m)
--              => e -> Maybe.Maybe a -> m a
--
-- nothingError error maybe =
--   case maybe of
--     Maybe.Nothing -> Error.throwError error
--     Maybe.Just vl -> pure vl