Prelude-2.0.0 defines (<>) inplace of (++)

module DemoApp.WithRedux where

import Prelude                   (Unit, bind, unit, pure, (-), (+), (<>))
import Unsafe.Coerce             (unsafeCoerce)
import Control.Monad.Eff         (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ractive (RactiveM, Ractive, Data(Data), on, ractive, get)
import Control.Monad.Eff.Redux   (ReduxM, Next, Store, subscribe, applyMiddleware, getState, dispatch)

-- | A simple reducer accepting two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

-- | Event handler for handling button clicks
onIncrementClicked :: forall event eff.
                      Ractive ->
                      event   ->
                      Eff (
                            ractiveM :: RactiveM,
                            reduxM   :: ReduxM,
                            console  :: CONSOLE
                            | eff
                          ) Unit
onIncrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "INCREMENT", payload: "TEST INCR" } store)
                             pure unit

-- | Event handler for handling button clicks
onDecrementClicked :: forall event eff.
                        Ractive ->
                        event   ->
                        Eff (
                              ractiveM :: RactiveM,
                              reduxM   :: ReduxM,
                              console  :: CONSOLE
                              | eff
                            ) Unit
onDecrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "DECREMENT", payload: "TEST DECR" } store)
                             pure unit

-- | A simple listener for displaying current state
numericListener :: forall e. Store -> Eff (reduxM :: ReduxM, console :: CONSOLE | e) Unit
numericListener = \store -> do
                     currentState <- (getState store)
                     log ("STATE: " <> (unsafeCoerce currentState))

-- | This is a middleware for logging
-- | It receives a subset of the Store API (getState & dispatch) and processes `actions`
simpleLogger :: forall a e. Store ->
                            (Next) ->
                            { "type" :: String, "payload" :: String | a } ->
                            Eff (
                              reduxM :: ReduxM,
                              console :: CONSOLE
                              | e
                              )
                            { "type" :: String, "payload" :: String | a }
simpleLogger = \store next action -> do
                                     log ("Middleware (Logger) :: Action: " <>
                                            action.type <> ", payload: " <>
                                            action.payload)
                                     (next action)

-- | The app starts here
main :: forall eff. Eff
          (
            console  :: CONSOLE,
            ractiveM :: RactiveM,
            reduxM   :: ReduxM
          | eff
          )
          Unit
main = do
       -- | Create an array of middlewares
       let middlewares = [ simpleLogger ]
       -- | Initialize a Redux Store while building up a chain of middlewares
       store <- (applyMiddleware middlewares counter 1)

       -- | ALTERNATIVE (without middleware)
       -- | Create a Redux Store by wiring up the `counter` Reducer and
       -- | the initial state `1`
       ---store <- (createStore counter 1)

       -- | Define UI's properties (RactiveJS)
       -- | Notice the presence of the property `store`. This is where we
       -- | save the reference to our Redux store. On each button click this
       -- | property will be used to change the app's state.
       let appSettings = Data {
                         template : "#template",
                         el       : "#app",
                         "data" : {
                                  library   : "Redux",
                                  language  : "PureScript",
                                  logoUrl   : "./content/img/ps-logo.png",
                                  message   : "Click on the PureScript Logo!",
                                  "store"   : store,
                                  uiLib     : "RactiveJS",
                                  counter   : 0,
                                  numbers   : []
                              }
                      }
       -- | Instantiate the UI
       ract <- ractive appSettings

       -- | Subscribe with listener `numericListener`
       (subscribe (numericListener store) store)

       -- Register event-handlers
       on "increment-clicked" (onIncrementClicked ract) ract
       on "decrement-clicked" (onDecrementClicked ract) ract

       log "Demo App with Redux!"

module DemoApp.WithRedux where

import Prelude                   (Unit, bind, unit, pure, (-), (+), (++))
import Unsafe.Coerce             (unsafeCoerce)
import Control.Monad.Eff         (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ractive (RactiveM, Ractive, Data(Data), on, ractive, get)
import Control.Monad.Eff.Redux   (ReduxM, Next, Store, subscribe, applyMiddleware, getState, dispatch)

-- | A simple reducer accepting two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

-- | Event handler for handling button clicks
onIncrementClicked :: forall event eff.
                      Ractive ->
                      event   ->
                      Eff (
                            ractiveM :: RactiveM,
                            reduxM   :: ReduxM,
                            console  :: CONSOLE
                            | eff
                          ) Unit
onIncrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "INCREMENT", payload: "TEST INCR" } store)
                             pure unit

-- | Event handler for handling button clicks
onDecrementClicked :: forall event eff.
                        Ractive ->
                        event   ->
                        Eff (
                              ractiveM :: RactiveM,
                              reduxM   :: ReduxM,
                              console  :: CONSOLE
                              | eff
                            ) Unit
onDecrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "DECREMENT", payload: "TEST DECR" } store)
                             pure unit

-- | A simple listener for displaying current state
numericListener :: forall e. Store -> Eff (reduxM :: ReduxM, console :: CONSOLE | e) Unit
numericListener = \store -> do
                     currentState <- (getState store)
                     log ("STATE: " ++ (unsafeCoerce currentState))

-- | This is a middleware for logging
-- | It receives a subset of the Store API (getState & dispatch) and processes `actions`
simpleLogger :: forall a e. Store ->
                            (Next) ->
                            { "type" :: String, "payload" :: String | a } ->
                            Eff (
                              reduxM :: ReduxM,
                              console :: CONSOLE
                              | e
                              )
                            { "type" :: String, "payload" :: String | a }
simpleLogger = \store next action -> do
                                     log ("Middleware (Logger) :: Action: " ++
                                            action.type ++ ", payload: " ++
                                            action.payload)
                                     (next action)

-- | The app starts here
main :: forall eff. Eff
          (
            console  :: CONSOLE,
            ractiveM :: RactiveM,
            reduxM   :: ReduxM
          | eff
          )
          Unit
main = do
       -- | Create an array of middlewares
       let middlewares = [ simpleLogger ]
       -- | Initialize a Redux Store while building up a chain of middlewares
       store <- (applyMiddleware middlewares counter 1)

       -- | ALTERNATIVE (without middleware)
       -- | Create a Redux Store by wiring up the `counter` Reducer and
       -- | the initial state `1`
       ---store <- (createStore counter 1)

       -- | Define UI's properties (RactiveJS)
       -- | Notice the presence of the property `store`. This is where we
       -- | save the reference to our Redux store. On each button click this
       -- | property will be used to change the app's state.
       let appSettings = Data {
                         template : "#template",
                         el       : "#app",
                         "data" : {
                                  library   : "Redux",
                                  language  : "PureScript",
                                  logoUrl   : "./content/img/ps-logo.png",
                                  message   : "Click on the PureScript Logo!",
                                  "store"   : store,
                                  uiLib     : "RactiveJS",
                                  counter   : 0,
                                  numbers   : []
                              }
                      }
       -- | Instantiate the UI
       ract <- ractive appSettings

       -- | Subscribe with listener `numericListener`
       (subscribe (numericListener store) store)

       -- Register event-handlers
       on "increment-clicked" (onIncrementClicked ract) ract
       on "decrement-clicked" (onDecrementClicked ract) ract

       log "Demo App with Redux!"


Fix wrong depth calculation

Fix wrong depth calculation

Use a `withLocalDepth` combinator to restore the current depth after
the inner parser ran. This problem became known after implementing
canonicalisation:

```
usage: prog [-a FOO | [[-a FOO] [-b FOO]]]
options:
  -a FOO [default: 100]
  -b FOO [default: 200]
```

Here, `$ a -x -b y` would fail because the first branch was falsly
elected as the winning branch and there is no mention of '-b' on that
branch a parser error occured.

module Language.Docopt.ArgParser.Parser (
    spec
  , initialState
  , module TypesReexport
  , module OptionsReexport
  ) where

import Prelude
import Debug.Profile
import Control.Plus (empty)
import Debug.Trace
import Data.Foreign
import Data.Map as Map
import Data.Map (Map())
import Control.Apply ((<*), (*>))
import Data.Function (on)
import Data.Function.Uncurried
import Data.Bifunctor (bimap, lmap, rmap)
import Data.Either (Either(Right, Left))
import Data.Maybe (Maybe(..), maybe, fromMaybe, maybe', isNothing, isJust, fromJust)
import Data.List (List(..), reverse, singleton, concat, length, (:),
                  some, filter, head, toUnfoldable, sortBy, groupBy, last, null,
                  tail, many, mapWithIndex, fromFoldable, take, drop)
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Control.Alt ((<|>))
import Data.Traversable (traverse, for)
import Control.Lazy (defer)
import Control.Monad (when, unless)
import Control.MonadPlus (guard)
import Data.Foldable (all, intercalate, maximumBy, sum, any, for_, foldl, elem)
import Data.String as String
import Data.String (fromCharArray, stripPrefix)
import Data.List.Partial as LU
import Data.Array as A
import Data.Array.Partial as AU
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import Control.Monad.Transformerless.RWS (RWS(), evalRWS, ask)
import Control.Monad.Transformerless.RWS (modify, get) as State
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.Map (empty, alter, lookup) as Map
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Text.Parsing.Parser (PState(..), ParseError(..), ParserT(..), Result(..), fail,
                            parseFailedFatal, parseFailed, unParserT, fatal) as P
import Text.Parsing.Parser.Combinators (option, try, lookAhead, (<?>), choice) as P
import Text.Parsing.Parser.Pos (Position) as P
import Partial.Unsafe (unsafePartial)

import Language.Docopt.ArgParser.Parser.Types as TypesReexport
import Language.Docopt.ArgParser.Parser.Options as OptionsReexport
import Language.Docopt.ArgParser.Parser.Types
import Language.Docopt.ArgParser.Parser.Options
import Language.Docopt.ArgParser.Parser.Token
import Language.Docopt.ArgParser.Parser.Fallback
import Language.Docopt.ArgParser.Parser.Atom

import Language.Docopt.Argument (Argument(..), Branch, isFree,
                                prettyPrintArg, prettyPrintArgNaked,
                                isRepeatable, OptionArgumentObj(),
                                setRequired, isOptional, isGroup,
                                unOptionArgument, isPositional, isCommand) as D
import Language.Docopt.OptionAlias (OptionAlias(..), isLong, isShort) as OptionAlias
import Language.Docopt.Env (Env ())
import Language.Docopt.Specification (Specification())
import Language.Docopt.Env as Env
import Language.Docopt.Origin as Origin
import Language.Docopt.Origin (Origin())
import Language.Docopt.Value as Value
import Language.Docopt.Value (Value(..))
import Language.Docopt.RichValue (RichValue(..), unRichValue, prettyPrintRichValue)
import Language.Docopt.RichValue (from, getOrigin) as RValue
import Language.Docopt.SpecParser.Base (getInput)
import Language.Docopt.ArgParser.Token (getSource) as Token
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..),
                                        unPositionedToken, prettyPrintToken)
import Data.String.Ext (startsWith, (~~))

-- | Toggle debugging on/off during development
debug :: Boolean
debug = false

initialState :: StateObj
initialState = {
  depth:  0
, done:   false
, failed: false
, cache:  Map.empty
}

withLocalCache :: ∀ a. Parser a -> Parser a
withLocalCache p = P.ParserT \st -> do
  storedState :: StateObj <- State.get
  State.modify \s -> s { cache = Map.empty :: Cache }
  v <- P.unParserT p st
  State.modify \s -> s { cache = storedState.cache }
  pure v

cached
  :: Required (Indexed D.Argument)
  -> Parser (List (Tuple D.Argument RichValue))
  -> Parser (List (Tuple D.Argument RichValue))
cached a p = P.ParserT \(s@(P.PState i _)) -> do
  state :: StateObj <- State.get
  let key = i /\ a
  maybe'
    (\_ -> do
      v <- P.unParserT p s
      State.modify \s -> s { cache = Map.alter (const (pure v)) key s.cache }
      pure v
    )
    pure
    (Map.lookup key state.cache)

modifyDepth :: (Int -> Int) -> Parser Unit
modifyDepth f = lift (State.modify \s -> s { depth = f s.depth })

setDepth :: Int -> Parser Unit
setDepth = modifyDepth <<< const

getDepth :: Parser Int
getDepth = _.depth <$> lift State.get

withLocalDepth :: ∀ a. Int -> Parser a -> Parser a
withLocalDepth d p = do
  d' <- getDepth
  setDepth 0 *> p <* setDepth d'

markDone :: Parser Unit
markDone = lift (State.modify \s -> s { done = true })

markFailed :: Parser Unit
markFailed = lift (State.modify \s -> s { failed = true })

unmarkFailed :: Parser Unit
unmarkFailed = lift (State.modify \s -> s { failed = false })

hasFailed :: Parser Boolean
hasFailed = _.failed <$> (lift State.get)

isDone :: Parser Boolean
isDone = _.done <$> (lift State.get)

skipIf :: ∀ a. Parser Boolean -> a -> Parser a -> Parser a
skipIf a b c = a >>= if _ then pure b else c

eof :: List D.Branch -> Parser Unit
eof branches = P.ParserT $ \(P.PState s pos) ->
  pure $ case s of
    Nil   -> P.Result s (Right unit) false pos
    (x:_) -> P.parseFailed s pos (unexpected branches x)

unexpected :: List D.Branch -> PositionedToken -> String
unexpected branches (PositionedToken {token: tok, source}) =
  let isKnown = any (any (p tok)) branches -- TODO: cache this
      prefix = if isKnown then "Unexpected " else "Unknown "
    in case tok of
      LOpt _ _   -> prefix <> "option " <> source
      SOpt _ _ _ -> prefix <> "option " <> source
      EOA _      -> prefix <> "option --"
      Stdin      -> prefix <> "option -"
      Lit _      -> prefix <> "command " <> source
  where
    p (LOpt n _)   (D.Option { aliases })   = elem (OptionAlias.Long n) aliases
    p (SOpt s _ _) (D.Option { aliases })   = elem (OptionAlias.Short s) aliases
    p (Lit n)      (D.Command { name: n' }) = n == n'
    p (EOA _)      (D.EOA)                  = true
    p (Stdin)      (D.Stdin)                = true
    p x            (D.Group { branches })   = any (any (p x)) branches
    p _            _                        = false

-- | Parse user input against a program specification.
spec
  :: ∀ r
   . Specification -- ^ the list of usage branches
  -> Options r    -- ^ argv parser options
  -> Parser (Tuple D.Branch (List ValueMapping))
spec xs options = do
  let
    -- Create a parser for each usage line.
    toplevel = concat xs
    parsers
      = toplevel <#> \branch -> do
          unmarkFailed
          vs <- withLocalCache do
            exhaustP toplevel true false 0 branch
          pure (Tuple branch vs)
          <* eof toplevel

  -- Evaluate the parsers, selecting the result with the most
  -- non-substituted values.
  evalParsers parsers \(Tuple _ vs) -> do
    sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs

  where

  -- Parse a list of arguments.
  -- Take care of clumping free vs. non-free (fixed) arguments.
  exhaustP
    :: ∀ r
     . List D.Branch   -- ^ the top-level branches
    -> Boolean         -- ^ can we skip using fallback values?
    -> Boolean         -- ^ are we currently skipping using fallback values?
    -> Int             -- ^ recursive level
    -> List D.Argument -- ^ the list of arguments to parse
    -> Parser (List ValueMapping)
  exhaustP toplevel skippable isSkipping l xs = do
    _debug \_->
        "exhaustP: "      <> (intercalate " " $ D.prettyPrintArg <$> xs)
      <> ", skippable: "  <> show skippable
      <> ", isSkipping: " <> show isSkipping

    concat <$> for (clump xs options.laxPlacement
                             options.optionsFirst
                             ) clumpP

    where

    -- Parse a clump of arguments.
    clumpP
      :: ∀ r
       . Clump (List D.Argument) -- ^ the clumps of arguments to parse.
      -> Parser (List ValueMapping)
    clumpP c = do

      i <- getInput
      _debug \_->
          "parsing clump: " <> prettyPrintArgClump c
        <> ", skippable: "  <> show skippable
        <> ", isSkipping: " <> show isSkipping
        <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)
      go l c

      where
      go l (Fixed xs) = concat <$> for xs (argP' skippable isSkipping l)

      go l (Free xs) =
        draw
          (xs `mapWithIndex'` \x ix -> Required (Indexed ix x))
          Map.empty
          (length xs)
        where

        draw
          :: List (Required (Indexed D.Argument))
          -> Map D.Argument P.ParseError
          -> Int
          -> Parser (List ValueMapping)

        draw xss@(x:xs) errs n | n >= 0 = skipIf isDone Nil (do

          i <- getInput
          _debug \_ ->
              "draw: "          <> (intercalate " " $ prettyPrintRequiredIndexedArg <$> xss)
            <> ", n: "          <> show n
            <> ", skippable: "  <> show skippable
            <> ", isSkipping: " <> show isSkipping
            <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)

          let
            arg = getIndexedElem (unRequired x)
            mod = if isRequired x then id else P.option Nil
            p   = argP' isSkipping  -- propagate the 'isSkipping' property
                        false       -- reset 'isSkipping' to false
                        (l + 1)     -- increase the recursive level
                        if not isSkipping
                           then D.setRequired arg true
                           else arg

          -- Try parsing the argument 'x'. If 'x' fails, enqueue it for a later
          -- try.  Should 'x' fail and should 'x' be skippable (i.e. it defines
          -- a default value or is backed by an environment variable),
          -- substitute x.  For groups, temporarily set the required flag to
          -- "true", such that it will fail and we have a chance to retry as
          -- part of the exhaustive parsing mechanism.  The 'cached' call
          -- ensures that we only parse a (arg, input) combo once per group.
          vs <- cached x $ P.try $ mod p

          _debug \_->
            "draw: matched: " <> (intercalate ", " $
              (vs) <#> \(Tuple k v) ->
                D.prettyPrintArg k <> " => " <> prettyPrintRichValue v
            )

          vss <- P.try do
            if (D.isRepeatable arg &&
              length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                then do
                  _debug \_->
                    "draw: repeating as optional: "
                      <> D.prettyPrintArg arg
                  -- Make successive matches of this repeated group optional.
                  draw (xs <> pure (toOptional x)) errs (length xss)
                else draw xs errs (length xs)

          _debug \_->
            "draw: matched (2): " <> (intercalate ", " $
              (vs <> vss) <#> \(Tuple k v) ->
                D.prettyPrintArg k <> " => " <> prettyPrintRichValue v
            )

          pure (vs <> vss)
        ) `catchParseError` (\e -> do
          let
            arg = getIndexedElem (unRequired x)
            isFixed = not <<< D.isFree
            errs' = if D.isGroup arg || not (D.isFree arg)
                        then Map.alter (const (Just e)) arg errs
                        else errs

          _debug \_->
              "draw: failure"
            <> ", requeueing: " <> prettyPrintRequiredIndexedArg x
            <> ", length of xs: " <> show (length xs)

          -- Check if we're done trying to recover.
          -- See the `draw -1` case below (`markFailed`).
          failed <- hasFailed
          if failed
            then do
              _debug \_ -> "draw: aborting (failed)"
              P.fail (_.message $ unParseError e)
            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            else if n == 0 || length xs == 0
              then
                let xs' = if isFixed arg then xss else (xs <> singleton x)
                in draw xs' errs' (-1)
              else
                let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                    xs' =
                      if D.isFree arg
                        then xs <> singleton x
                        -- XXX: Future work could include slicing off those
                        -- branches in the group that are 'free' and re-queueing
                        -- those.
                        else
                          let fs = take n xss
                              rs = drop n xss
                          in sortBy (compare `on` isFixed') fs <> rs
                in draw xs' errs' (n - 1)
          )

        -- All arguments have been matched (or have failed to be matched) at least
        -- once by now. See where we're at - is there any required argument that was
        -- not matched at all?
        draw xss@(x:xs) errs n | (n < 0) = skipIf isDone Nil do

          i <- getInput
          _debug \_->
              "draw: edge-case"
            <> ", left-over: "  <> (intercalate " " $ prettyPrintRequiredIndexedArg <$> xss)
            <> ", n: "          <> show n
            <> ", skippable: "  <> show skippable
            <> ", isSkipping: " <> show isSkipping
            <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)

          env <- lift ask

          let
            xss' = sortBy (compare `on` (getIndex <<< unRequired)) xss
            args = getIndexedElem <<< unRequired <$> xss'
            vs   = args <#> \arg -> do
              maybe
                (Left arg)
                (Right <<< Tuple arg)
                do
                  v <- unRichValue <$> getFallbackValue options env arg
                  pure $ RichValue v {
                    value = if D.isRepeatable arg
                        then ArrayValue $ Value.intoArray v.value
                        else v.value
                  }
            missing = mlefts vs `flip filter` (\arg ->
              isRequired x &&
              -- This may look very counter-intuitive, yet getting fallback
              -- values for entire groups is not possible and not logical.
              -- If a group that is allowed to be omitted fails, there won't
              -- be any values to fall back onto.
              not (D.isGroup arg && D.isOptional arg)
            )
            fallbacks = mrights vs

          _debug \_->
            "draw: missing: "
              <> (intercalate " " $ D.prettyPrintArg <$> missing)

          if isSkipping && length missing > 0
            then do
              _debug \_-> "draw: marking as failed"
              markFailed
              expected missing i
            else
              if skippable || null i
                then
                  if not isSkipping
                    then withLocalCache do
                      exhaustP toplevel true true l args
                    else pure fallbacks
                else expected args i

          where
          expected xs i =
            let
              x = unsafePartial (LU.head xs)
              msg = maybe'
                (\_ -> case i of
                  i':_ -> unexpected toplevel i'
                            <> ". Expected "
                            <> (intercalate ", " $ D.prettyPrintArgNaked <$> xs)
                  Nil  -> "Missing "
                            <> (intercalate ", " $ D.prettyPrintArgNaked <$> xs)
                )
                (\(P.ParseError msg _ _) -> msg)
                (x `Map.lookup` errs)
            in P.fail msg

        draw _ _ _ = pure Nil

    -- Parse a single argument from argv.
    argP'
      :: ∀ r
       . Boolean       -- ^ can we skip using fallback values?
      -> Boolean       -- ^ are we currently skipping using fallback values?
      -> Int           -- ^ recursive level
      -> D.Argument    -- ^ the argument to parse
      -> Parser (List ValueMapping)
    argP' skippable isSkipping l x = skipIf isDone Nil $ argP x

      where
      -- Parse a single argument from argv.
      argP :: D.Argument -> Parser (List ValueMapping)

      -- Terminate at singleton groups that house only positionals.
      argP x | options.optionsFirst && isTerm x
        = let y = unsafePartial (fromJust (termAs x))
          in singleton <<< Tuple y <<< (RValue.from Origin.Argv) <$> terminate y

      -- The recursive branch of the argv argument parser.
      -- For groups, each branch is run and analyzed.
      argP g@(D.Group grp) = do
        -- Create a parser for each branch in the group
        let
          parsers = grp.branches <#> \branch ->
            withLocalCache do
              exhaustP toplevel skippable isSkipping l branch

        -- Evaluate the parsers, selecting the result with the most
        -- non-substituted values.
        vs <- (if grp.optional then P.option Nil else id) do
          evalParsers parsers \p ->
            sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> p

        hasInput <- not <<< null <$> getInput
        vss <- if (hasInput && grp.repeatable &&
                length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then loop Nil
                  else pure Nil

        pure $ vs <> vss

        where
          loop acc = do
            vs <- do
                argP' skippable isSkipping l
                      (D.Group grp { optional = true })
            if (length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
              then loop $ acc <> vs
              else pure acc

      -- The non-recursive branch of the argv argument parser.
      -- All of these parsers consume one or more adjacent arguments from argv.
      argP x = getInput >>= \i -> (
        (if D.isRepeatable x then some else liftM1 singleton) do
          Tuple x <<< (RValue.from Origin.Argv) <$> do
            P.ParserT $ \s -> do
              (o@(P.Result input result consumed pos)) <- P.unParserT (unsafePartial $ go x) s

              -- Check error messages for fatal errors.
              -- XXX: This should also change.
              case result of
                (Left e) -> do
                  let err = unParseError e
                  if ((startsWith "Option takes no argument" err.message) ||
                      (startsWith "Option requires argument" err.message))
                    then do
                      pure (P.Result
                              input
                              (Left $ P.ParseError err.message err.position true)
                              consumed
                              pos)
                    else pure o
                otherwise -> pure o
          <* modifyDepth (_ + 1)
        ) <|> P.fail ("Expected " <> D.prettyPrintArgNaked x <> butGot i)

        where
        go :: Partial => _ _
        go (D.Positional pos) = positional pos.name
        go (D.Command    cmd) = command    cmd.name
        go (D.Stdin         ) = stdin
        go (D.EOA           ) = eoa <|> (pure $ ArrayValue [])
        go (x@(D.Option   o)) = do

          -- Perform a pre-cursory test in order to capture relevant error
          -- messags which would otherwise be overriden (e.g. a meaningful
          -- error message when trying to match a LOpt against a LOpt would
          -- be overridden by a meaningless try to match a SOpt against a
          -- a LOpt).

          isLoptAhead <- P.option false (P.lookAhead $ token isAnyLopt)
          isSoptAhead <- P.option false (P.lookAhead $ token isAnySopt)

          let
            ns = fromFoldable
                  $ o.aliases <#> case _ of
                    OptionAlias.Short f -> Left  f
                    OptionAlias.Long  n -> Right n
            term = any (_ `elem` options.stopAt) $ o.aliases <#> case _ of
                      OptionAlias.Short s -> "-"  ~~ (String.singleton s)
                      OptionAlias.Long  n -> "--" ~~ n

          -- try each alias
          v /\ canTerm /\ canRepeat <- case 0 of
            _ | isLoptAhead ->
              let ls = mrights ns
               in if null ls
                    then P.fail "Option has no long alias"
                    else P.choice $ ls <#> \n -> P.try do
                      let mOptArg = D.unOptionArgument <$> o.arg
                      { value, canRepeat } <- longOption term n mOptArg
                      pure (value /\ true /\ canRepeat)
            _ | isSoptAhead ->
              let cs = mlefts ns
               in if null cs
                    then P.fail "Option has no short alias"
                    else P.choice $ cs <#> \c -> P.try do
                      let mOptArg = D.unOptionArgument <$> o.arg
                      { value, canRepeat, canTerm } <- shortOption term c mOptArg
                      pure (value /\ canTerm /\ canRepeat)
            _ -> P.fail "Expected long or short option"

          -- try terminating at this option
          if term && canTerm
              then do
                vs <- terminate x
                pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
              else do
                if isJust o.arg && o.repeatable && canRepeat
                    then do
                      vs <- A.many optionArgument
                      pure (ArrayValue (Value.intoArray v <> vs))
                    else pure v

          where
          isAnyLopt (LOpt _ _)   = pure true
          isAnyLopt _            = pure false
          isAnySopt (SOpt _ _ _) = pure true
          isAnySopt _            = pure false

    butGot ((PositionedToken { source }):_) = ", but got " <> source
    butGot _ = ""

    indentation :: String
    indentation = fromCharArray $ LL.toUnfoldable $ LL.take (l * 4) $ LL.repeat ' '

    _debug s = if debug
                  then traceA $ indentation <> (s unit)
                  else pure unit

-- Evaluate multiple parsers, producing a new parser that chooses the best
-- succeeding match or none.
evalParsers
  :: ∀ a b
   . (Show a, Ord b)
  => List (Parser a)
  -> (a -> b)
  -> Parser a
evalParsers parsers p = do
  P.ParserT \(pState@(P.PState i pos)) -> do
    env   :: Env      <- ask
    state :: StateObj <- State.get

    let
      -- Run each parser in the underlying monad and capture any errors
      -- that occur as well as the result. This essentially circumvents
      -- `ParserT`'s bind instance.
      collect = for parsers \parser -> do
        -- reset the depth for every branch
        (P.Result s result consumed pos) <- P.unParserT (withLocalDepth 0 parser) pState
        state' :: StateObj <- State.get
        pure case result of
          (Left err) -> Left  {
            input:    s
          , result:   {
              error: err
            , depth: state'.depth + state.depth
            }
          , consumed: consumed
          , position: pos
          }
          (Right a)  -> Right {
            input:    s
          , result: {
              value: a
            , depth: state'.depth + state.depth
            , done:  state'.done
            }
          , consumed: consumed
          , position: pos
          }

      -- Evaluate the parsers.
      results    = fst $ evalRWS collect env initialState
      successes  = mrights results
      successes' = reverse successes
      failures   = mlefts results

      -- Evaluate any failed parses
      losers = last
        $ groupBy (eq `on` (_.depth <<< _.result))
                  (sortBy (compare `on` (_.depth <<< _.result))
                          failures)

      -- Check for any fatal errors. These must take priority!
      -- The first fatal error to occur takes priority.
      fatal = head
        $ filter (\x -> _.fatal $ unParseError (x.result.error))
                  failures

      -- Evaluate any winning candidates.
      -- First, sort the results by their depth, then group consecutive
      -- elements, take the highest element and sort the inner values by using
      -- the user provided function.
      winner = do
        x <- last $ groupBy (eq `on` (_.depth <<< _.result))
                        (sortBy (compare `on` (_.depth <<< _.result))
                                successes')
        maximumBy (compare `on` (\y -> p y.result.value)) x

    -- Finally, evaluate the results!
    maybe
      (do
        maybe'
          (\_ ->
            fromMaybe
              (pure do
                P.parseFailed i pos
                    "The impossible happened. Failure without error")
              (do
                es <- losers
                pure case es of
                  e:es | null es || not (null i) -> do
                    pure (P.Result e.input (Left e.result.error) e.consumed e.position)
                  otherwise -> pure $ P.parseFailed i pos ""
              )
          )
          (\r ->  do
            State.modify (_ { done = r.result.done })
            pure $ P.Result r.input
                            (Right r.result.value)
                            r.consumed
                            r.position
          )
          winner
      )
      (\x ->
        let err = unParseError (x.result.error)
         in pure $ P.parseFailedFatal i pos err.message
      )
      fatal

-- Terminate the parser at the given argument and collect all subsequent
-- values int an array ("options-first" and "stop-at")
terminate :: D.Argument -> Parser Value
terminate arg = do
  input <- getInput
  let rest = ArrayValue $ toUnfoldable $ StringValue <<< Token.getSource <$> input
  markDone
  modifyDepth (const 99999)
  P.ParserT \(P.PState _ pos) -> pure (P.Result Nil (Right rest) true pos)

isFrom :: Origin -> RichValue -> Boolean
isFrom o rv = o == RValue.getOrigin rv

unParseError :: P.ParseError -> { position :: P.Position, message :: String, fatal :: Boolean }
unParseError (P.ParseError message position fatal) = { message, position, fatal }

mapWithIndex' = flip mapWithIndex

-- Clump together arguments to aid parsing "invisible" subgroups, where
-- arguments may appear in any order, for example. "Fixed" argument lists
-- are parsed in fixed order, whereas "Free" argument lists, can be parsed in
-- any order.
clump
  :: List D.Argument -- ^ the list of arguments to clump
  -> Boolean         -- ^ allow lax placement?
  -> Boolean         -- ^ are we parsing options first?
  -> List (Clump (List D.Argument))
clump xs lax optsFirst = reverse $ foldl go Nil xs
  where
  go (Nil) x = pure $ (if isFree x then Free else Fixed) $ singleton x
  go   ((Free a) :zs) x | isFree x = (Free (a <> (singleton x))) : zs
  go u@((Free _) :_ ) x = (Fixed $ singleton x) : u
  go u@((Fixed _):_ ) x | isFree x = (Free $ singleton x): u
  go   ((Fixed a):zs) x = (Fixed (a <> (singleton x))) : zs
  isFree x = (lax || D.isFree x) && (not (optsFirst && isTerm x))

-- Note: Unfortunate re-implementation of the 'Alt' instance for 'ParserT'.
catchParseError :: ∀ a. Parser a -> (P.ParseError -> Parser a) -> Parser a
catchParseError p1 f2 = P.ParserT \st ->
  P.unParserT p1 st >>= \(o@(P.Result input result consumed pos)) ->
    case result of
      Left (P.ParseError _ _ true) -> pure o
      Left e | not consumed        -> P.unParserT (f2 e) st
      otherwise                    -> pure o

termAs :: D.Argument -> Maybe D.Argument
termAs (D.Group (grp@{ branches: (x@(D.Positional pos):Nil) : Nil }))
  | pos.repeatable || grp.repeatable = Just x
termAs x@(D.Positional pos) | pos.repeatable = Just x
termAs _ = Nothing

isTerm :: D.Argument -> Boolean
isTerm = isJust <<< termAs

module Language.Docopt.ArgParser.Parser (
    spec
  , initialState
  , module TypesReexport
  , module OptionsReexport
  ) where

import Prelude
import Debug.Profile
import Control.Plus (empty)
import Debug.Trace
import Data.Foreign
import Data.Map as Map
import Data.Map (Map())
import Control.Apply ((<*), (*>))
import Data.Function (on)
import Data.Function.Uncurried
import Data.Bifunctor (bimap, lmap, rmap)
import Data.Either (Either(Right, Left))
import Data.Maybe (Maybe(..), maybe, fromMaybe, maybe', isNothing, isJust, fromJust)
import Data.List (List(..), reverse, singleton, concat, length, (:),
                  some, filter, head, toUnfoldable, sortBy, groupBy, last, null,
                  tail, many, mapWithIndex, fromFoldable, take, drop)
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Control.Alt ((<|>))
import Data.Traversable (traverse, for)
import Control.Lazy (defer)
import Control.Monad (when, unless)
import Control.MonadPlus (guard)
import Data.Foldable (all, intercalate, maximumBy, sum, any, for_, foldl, elem)
import Data.String as String
import Data.String (fromCharArray, stripPrefix)
import Data.List.Partial as LU
import Data.Array as A
import Data.Array.Partial as AU
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import Control.Monad.Transformerless.RWS (RWS(), evalRWS, ask)
import Control.Monad.Transformerless.RWS (modify, get) as State
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.Map (empty, alter, lookup) as Map
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Text.Parsing.Parser (PState(..), ParseError(..), ParserT(..), Result(..), fail,
                            parseFailedFatal, parseFailed, unParserT, fatal) as P
import Text.Parsing.Parser.Combinators (option, try, lookAhead, (<?>), choice) as P
import Text.Parsing.Parser.Pos (Position) as P
import Partial.Unsafe (unsafePartial)

import Language.Docopt.ArgParser.Parser.Types as TypesReexport
import Language.Docopt.ArgParser.Parser.Options as OptionsReexport
import Language.Docopt.ArgParser.Parser.Types
import Language.Docopt.ArgParser.Parser.Options
import Language.Docopt.ArgParser.Parser.Token
import Language.Docopt.ArgParser.Parser.Fallback
import Language.Docopt.ArgParser.Parser.Atom

import Language.Docopt.Argument (Argument(..), Branch, isFree,
                                prettyPrintArg, prettyPrintArgNaked,
                                isRepeatable, OptionArgumentObj(),
                                setRequired, isOptional, isGroup,
                                unOptionArgument, isPositional, isCommand) as D
import Language.Docopt.OptionAlias (OptionAlias(..), isLong, isShort) as OptionAlias
import Language.Docopt.Env (Env ())
import Language.Docopt.Specification (Specification())
import Language.Docopt.Env as Env
import Language.Docopt.Origin as Origin
import Language.Docopt.Origin (Origin())
import Language.Docopt.Value as Value
import Language.Docopt.Value (Value(..))
import Language.Docopt.RichValue (RichValue(..), unRichValue, prettyPrintRichValue)
import Language.Docopt.RichValue (from, getOrigin) as RValue
import Language.Docopt.SpecParser.Base (getInput)
import Language.Docopt.ArgParser.Token (getSource) as Token
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..),
                                        unPositionedToken, prettyPrintToken)
import Data.String.Ext (startsWith, (~~))

-- | Toggle debugging on/off during development
debug :: Boolean
debug = false

initialState :: StateObj
initialState = {
  depth:  0
, done:   false
, failed: false
, cache:  Map.empty
}

withLocalCache :: ∀ a. Parser a -> Parser a
withLocalCache p = P.ParserT \st -> do
  storedState :: StateObj <- State.get
  State.modify \s -> s { cache = Map.empty :: Cache }
  v <- P.unParserT p st
  State.modify \s -> s { cache = storedState.cache }
  pure v

cached
  :: Required (Indexed D.Argument)
  -> Parser (List (Tuple D.Argument RichValue))
  -> Parser (List (Tuple D.Argument RichValue))
cached a p = P.ParserT \(s@(P.PState i _)) -> do
  state :: StateObj <- State.get
  let key = i /\ a
  maybe'
    (\_ -> do
      v <- P.unParserT p s
      State.modify \s -> s { cache = Map.alter (const (pure v)) key s.cache }
      pure v
    )
    pure
    (Map.lookup key state.cache)

modifyDepth :: (Int -> Int) -> Parser Unit
modifyDepth f = lift (State.modify \s -> s { depth = f s.depth })

markDone :: Parser Unit
markDone = lift (State.modify \s -> s { done = true })

markFailed :: Parser Unit
markFailed = lift (State.modify \s -> s { failed = true })

unmarkFailed :: Parser Unit
unmarkFailed = lift (State.modify \s -> s { failed = false })

hasFailed :: Parser Boolean
hasFailed = _.failed <$> (lift State.get)

isDone :: Parser Boolean
isDone = _.done <$> (lift State.get)

skipIf :: ∀ a. Parser Boolean -> a -> Parser a -> Parser a
skipIf a b c = a >>= if _ then pure b else c

eof :: List D.Branch -> Parser Unit
eof branches = P.ParserT $ \(P.PState s pos) ->
  pure $ case s of
    Nil   -> P.Result s (Right unit) false pos
    (x:_) -> P.parseFailed s pos (unexpected branches x)

unexpected :: List D.Branch -> PositionedToken -> String
unexpected branches (PositionedToken {token: tok, source}) =
  let isKnown = any (any (p tok)) branches -- TODO: cache this
      prefix = if isKnown then "Unexpected " else "Unknown "
    in case tok of
      LOpt _ _   -> prefix <> "option " <> source
      SOpt _ _ _ -> prefix <> "option " <> source
      EOA _      -> prefix <> "option --"
      Stdin      -> prefix <> "option -"
      Lit _      -> prefix <> "command " <> source
  where
    p (LOpt n _)   (D.Option { aliases })   = elem (OptionAlias.Long n) aliases
    p (SOpt s _ _) (D.Option { aliases })   = elem (OptionAlias.Short s) aliases
    p (Lit n)      (D.Command { name: n' }) = n == n'
    p (EOA _)      (D.EOA)                  = true
    p (Stdin)      (D.Stdin)                = true
    p x            (D.Group { branches })   = any (any (p x)) branches
    p _            _                        = false

-- | Parse user input against a program specification.
spec
  :: ∀ r
   . Specification -- ^ the list of usage branches
  -> Options r    -- ^ argv parser options
  -> Parser (Tuple D.Branch (List ValueMapping))
spec xs options = do
  let
    -- Create a parser for each usage line.
    toplevel = concat xs
    parsers
      = toplevel <#> \branch -> do
          unmarkFailed
          vs <- withLocalCache do
            exhaustP toplevel true false 0 branch
          pure (Tuple branch vs)
          <* eof toplevel

  -- Evaluate the parsers, selecting the result with the most
  -- non-substituted values.
  evalParsers parsers \(Tuple _ vs) -> do
    sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs

  where

  -- Parse a list of arguments.
  -- Take care of clumping free vs. non-free (fixed) arguments.
  exhaustP
    :: ∀ r
     . List D.Branch   -- ^ the top-level branches
    -> Boolean         -- ^ can we skip using fallback values?
    -> Boolean         -- ^ are we currently skipping using fallback values?
    -> Int             -- ^ recursive level
    -> List D.Argument -- ^ the list of arguments to parse
    -> Parser (List ValueMapping)
  exhaustP toplevel skippable isSkipping l xs = do
    _debug \_->
        "exhaustP: "      <> (intercalate " " $ D.prettyPrintArg <$> xs)
      <> ", skippable: "  <> show skippable
      <> ", isSkipping: " <> show isSkipping

    concat <$> for (clump xs options.laxPlacement
                             options.optionsFirst
                             ) clumpP

    where

    -- Parse a clump of arguments.
    clumpP
      :: ∀ r
       . Clump (List D.Argument) -- ^ the clumps of arguments to parse.
      -> Parser (List ValueMapping)
    clumpP c = do

      i <- getInput
      _debug \_->
          "parsing clump: " <> prettyPrintArgClump c
        <> ", skippable: "  <> show skippable
        <> ", isSkipping: " <> show isSkipping
        <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)
      go l c

      where
      go l (Fixed xs) = concat <$> for xs (argP' skippable isSkipping l)

      go l (Free xs) =
        draw
          (xs `mapWithIndex'` \x ix -> Required (Indexed ix x))
          Map.empty
          (length xs)
        where

        draw
          :: List (Required (Indexed D.Argument))
          -> Map D.Argument P.ParseError
          -> Int
          -> Parser (List ValueMapping)

        draw xss@(x:xs) errs n | n >= 0 = skipIf isDone Nil (do

          i <- getInput
          _debug \_ ->
              "draw: "          <> (intercalate " " $ prettyPrintRequiredIndexedArg <$> xss)
            <> ", n: "          <> show n
            <> ", skippable: "  <> show skippable
            <> ", isSkipping: " <> show isSkipping
            <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)

          let
            arg = getIndexedElem (unRequired x)
            mod = if isRequired x then id else P.option Nil
            p   = argP' isSkipping  -- propagate the 'isSkipping' property
                        false       -- reset 'isSkipping' to false
                        (l + 1)     -- increase the recursive level
                        if not isSkipping
                           then D.setRequired arg true
                           else arg

          -- Try parsing the argument 'x'. If 'x' fails, enqueue it for a later
          -- try.  Should 'x' fail and should 'x' be skippable (i.e. it defines
          -- a default value or is backed by an environment variable),
          -- substitute x.  For groups, temporarily set the required flag to
          -- "true", such that it will fail and we have a chance to retry as
          -- part of the exhaustive parsing mechanism.  The 'cached' call
          -- ensures that we only parse a (arg, input) combo once per group.
          vs <- cached x $ P.try $ mod p

          _debug \_->
            "draw: matched: " <> (intercalate ", " $
              (vs) <#> \(Tuple k v) ->
                D.prettyPrintArg k <> " => " <> prettyPrintRichValue v
            )

          vss <- P.try do
            if (D.isRepeatable arg &&
              length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                then do
                  _debug \_->
                    "draw: repeating as optional: "
                      <> D.prettyPrintArg arg
                  -- Make successive matches of this repeated group optional.
                  draw (xs <> pure (toOptional x)) errs (length xss)
                else draw xs errs (length xs)

          _debug \_->
            "draw: matched (2): " <> (intercalate ", " $
              (vs <> vss) <#> \(Tuple k v) ->
                D.prettyPrintArg k <> " => " <> prettyPrintRichValue v
            )

          pure (vs <> vss)
        ) `catchParseError` (\e -> do
          let
            arg = getIndexedElem (unRequired x)
            isFixed = not <<< D.isFree
            errs' = if D.isGroup arg || not (D.isFree arg)
                        then Map.alter (const (Just e)) arg errs
                        else errs

          _debug \_->
              "draw: failure"
            <> ", requeueing: " <> prettyPrintRequiredIndexedArg x
            <> ", length of xs: " <> show (length xs)

          -- Check if we're done trying to recover.
          -- See the `draw -1` case below (`markFailed`).
          failed <- hasFailed
          if failed
            then do
              _debug \_ -> "draw: aborting (failed)"
              P.fail (_.message $ unParseError e)
            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            else if n == 0 || length xs == 0
              then
                let xs' = if isFixed arg then xss else (xs <> singleton x)
                in draw xs' errs' (-1)
              else
                let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                    xs' =
                      if D.isFree arg
                        then xs <> singleton x
                        -- XXX: Future work could include slicing off those
                        -- branches in the group that are 'free' and re-queueing
                        -- those.
                        else
                          let fs = take n xss
                              rs = drop n xss
                          in sortBy (compare `on` isFixed') fs <> rs
                in draw xs' errs' (n - 1)
          )

        -- All arguments have been matched (or have failed to be matched) at least
        -- once by now. See where we're at - is there any required argument that was
        -- not matched at all?
        draw xss@(x:xs) errs n | (n < 0) = skipIf isDone Nil do

          i <- getInput
          _debug \_->
              "draw: edge-case"
            <> ", left-over: "  <> (intercalate " " $ prettyPrintRequiredIndexedArg <$> xss)
            <> ", n: "          <> show n
            <> ", skippable: "  <> show skippable
            <> ", isSkipping: " <> show isSkipping
            <> ", input: "      <> show (intercalate " " $ Token.getSource <$> i)

          env <- lift ask

          let
            xss' = sortBy (compare `on` (getIndex <<< unRequired)) xss
            args = getIndexedElem <<< unRequired <$> xss'
            vs   = args <#> \arg -> do
              maybe
                (Left arg)
                (Right <<< Tuple arg)
                do
                  v <- unRichValue <$> getFallbackValue options env arg
                  pure $ RichValue v {
                    value = if D.isRepeatable arg
                        then ArrayValue $ Value.intoArray v.value
                        else v.value
                  }
            missing = mlefts vs `flip filter` (\arg ->
              isRequired x &&
              -- This may look very counter-intuitive, yet getting fallback
              -- values for entire groups is not possible and not logical.
              -- If a group that is allowed to be omitted fails, there won't
              -- be any values to fall back onto.
              not (D.isGroup arg && D.isOptional arg)
            )
            fallbacks = mrights vs

          _debug \_->
            "draw: missing: "
              <> (intercalate " " $ D.prettyPrintArg <$> missing)

          if isSkipping && length missing > 0
            then do
              _debug \_-> "draw: marking as failed"
              markFailed
              expected missing i
            else
              if skippable || null i
                then
                  if not isSkipping
                    then withLocalCache do
                      exhaustP toplevel true true l args
                    else pure fallbacks
                else expected args i

          where
          expected xs i =
            let
              x = unsafePartial (LU.head xs)
              msg = maybe'
                (\_ -> case i of
                  i':_ -> unexpected toplevel i'
                            <> ". Expected "
                            <> (intercalate ", " $ D.prettyPrintArgNaked <$> xs)
                  Nil  -> "Missing "
                            <> (intercalate ", " $ D.prettyPrintArgNaked <$> xs)
                )
                (\(P.ParseError msg _ _) -> msg)
                (x `Map.lookup` errs)
            in P.fail msg

        draw _ _ _ = pure Nil

    -- Parse a single argument from argv.
    argP'
      :: ∀ r
       . Boolean       -- ^ can we skip using fallback values?
      -> Boolean       -- ^ are we currently skipping using fallback values?
      -> Int           -- ^ recursive level
      -> D.Argument    -- ^ the argument to parse
      -> Parser (List ValueMapping)
    argP' skippable isSkipping l x = skipIf isDone Nil $ argP x

      where
      -- Parse a single argument from argv.
      argP :: D.Argument -> Parser (List ValueMapping)

      -- Terminate at singleton groups that house only positionals.
      argP x | options.optionsFirst && isTerm x
        = let y = unsafePartial (fromJust (termAs x))
          in singleton <<< Tuple y <<< (RValue.from Origin.Argv) <$> terminate y

      -- The recursive branch of the argv argument parser.
      -- For groups, each branch is run and analyzed.
      argP g@(D.Group grp) = do
        -- Create a parser for each branch in the group
        let
          parsers = grp.branches <#> \branch ->
            withLocalCache do
              exhaustP toplevel skippable isSkipping l branch

        -- Evaluate the parsers, selecting the result with the most
        -- non-substituted values.
        vs <- (if grp.optional then P.option Nil else id) do
          evalParsers parsers \p ->
            sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> p

        hasInput <- not <<< null <$> getInput
        vss <- if (hasInput && grp.repeatable &&
                length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
                  then loop Nil
                  else pure Nil

        pure $ vs <> vss

        where
          loop acc = do
            vs <- do
                argP' skippable isSkipping l
                      (D.Group grp { optional = true })
            if (length (filter (snd >>> isFrom Origin.Argv) vs) > 0)
              then loop $ acc <> vs
              else pure acc

      -- The non-recursive branch of the argv argument parser.
      -- All of these parsers consume one or more adjacent arguments from argv.
      argP x = getInput >>= \i -> (
        (if D.isRepeatable x then some else liftM1 singleton) do
          Tuple x <<< (RValue.from Origin.Argv) <$> do
            P.ParserT $ \s -> do
              (o@(P.Result input result consumed pos)) <- P.unParserT (unsafePartial $ go x) s

              -- Check error messages for fatal errors.
              -- XXX: This should also change.
              case result of
                (Left e) -> do
                  let err = unParseError e
                  if ((startsWith "Option takes no argument" err.message) ||
                      (startsWith "Option requires argument" err.message))
                    then do
                      pure (P.Result
                              input
                              (Left $ P.ParseError err.message err.position true)
                              consumed
                              pos)
                    else pure o
                otherwise -> pure o
          <* modifyDepth (_ + 1)
        ) <|> P.fail ("Expected " <> D.prettyPrintArgNaked x <> butGot i)

        where
        go :: Partial => _ _
        go (D.Positional pos) = positional pos.name
        go (D.Command    cmd) = command    cmd.name
        go (D.Stdin         ) = stdin
        go (D.EOA           ) = eoa <|> (pure $ ArrayValue [])
        go (x@(D.Option   o)) = do

          -- Perform a pre-cursory test in order to capture relevant error
          -- messags which would otherwise be overriden (e.g. a meaningful
          -- error message when trying to match a LOpt against a LOpt would
          -- be overridden by a meaningless try to match a SOpt against a
          -- a LOpt).

          isLoptAhead <- P.option false (P.lookAhead $ token isAnyLopt)
          isSoptAhead <- P.option false (P.lookAhead $ token isAnySopt)

          let
            ns = fromFoldable
                  $ o.aliases <#> case _ of
                    OptionAlias.Short f -> Left  f
                    OptionAlias.Long  n -> Right n
            term = any (_ `elem` options.stopAt) $ o.aliases <#> case _ of
                      OptionAlias.Short s -> "-"  ~~ (String.singleton s)
                      OptionAlias.Long  n -> "--" ~~ n

          -- try each alias
          v /\ canTerm /\ canRepeat <- case 0 of
            _ | isLoptAhead ->
              let ls = mrights ns
               in if null ls
                    then P.fail "Option has no long alias"
                    else P.choice $ ls <#> \n -> P.try do
                      let mOptArg = D.unOptionArgument <$> o.arg
                      { value, canRepeat } <- longOption term n mOptArg
                      pure (value /\ true /\ canRepeat)
            _ | isSoptAhead ->
              let cs = mlefts ns
               in if null cs
                    then P.fail "Option has no short alias"
                    else P.choice $ cs <#> \c -> P.try do
                      let mOptArg = D.unOptionArgument <$> o.arg
                      { value, canRepeat, canTerm } <- shortOption term c mOptArg
                      pure (value /\ canTerm /\ canRepeat)
            _ -> P.fail "Expected long or short option"

          -- try terminating at this option
          if term && canTerm
              then do
                vs <- terminate x
                pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
              else do
                if isJust o.arg && o.repeatable && canRepeat
                    then do
                      vs <- A.many optionArgument
                      pure (ArrayValue (Value.intoArray v <> vs))
                    else pure v

          where
          isAnyLopt (LOpt _ _)   = pure true
          isAnyLopt _            = pure false
          isAnySopt (SOpt _ _ _) = pure true
          isAnySopt _            = pure false

    butGot ((PositionedToken { source }):_) = ", but got " <> source
    butGot _ = ""

    indentation :: String
    indentation = fromCharArray $ LL.toUnfoldable $ LL.take (l * 4) $ LL.repeat ' '

    _debug s = if debug
                  then traceA $ indentation <> (s unit)
                  else pure unit

-- Evaluate multiple parsers, producing a new parser that chooses the best
-- succeeding match or none.
evalParsers
  :: ∀ a b
   . (Show a, Ord b)
  => List (Parser a)
  -> (a -> b)
  -> Parser a
evalParsers parsers p = do
  P.ParserT \(pState@(P.PState i pos)) -> do
    env   :: Env      <- ask
    state :: StateObj <- State.get

    let
      -- Run each parser in the underlying monad and capture any errors
      -- that occur as well as the result. This essentially circumvents
      -- `ParserT`'s bind instance.
      collect = for parsers \parser -> do
        -- reset the depth for every branch
        (P.Result s result consumed pos) <- P.unParserT (modifyDepth (const 0) *> parser) pState
        state' :: StateObj <- State.get
        pure case result of
          (Left err) -> Left  {
            input:    s
          , result:   {
              error: err
            , depth: state'.depth + state.depth
            }
          , consumed: consumed
          , position: pos
          }
          (Right a)  -> Right {
            input:    s
          , result: {
              value: a
            , depth: state'.depth + state.depth
            , done:  state'.done
            }
          , consumed: consumed
          , position: pos
          }

      -- Evaluate the parsers.
      results    = fst $ evalRWS collect env initialState
      successes  = mrights results
      successes' = reverse successes
      failures   = mlefts results

      -- Evaluate any failed parses
      losers = last
        $ groupBy (eq `on` (_.depth <<< _.result))
                  (sortBy (compare `on` (_.depth <<< _.result))
                          failures)

      -- Check for any fatal errors. These must take priority!
      -- The first fatal error to occur takes priority.
      fatal = head
        $ filter (\x -> _.fatal $ unParseError (x.result.error))
                  failures

      -- Evaluate any winning candidates.
      -- First, sort the results by their depth, then group consecutive
      -- elements, take the highest element and sort the inner values by using
      -- the user provided function.
      winner = do
        x <- last $ groupBy (eq `on` (_.depth <<< _.result))
                        (sortBy (compare `on` (_.depth <<< _.result))
                                successes')
        maximumBy (compare `on` (\y -> p y.result.value)) x

    -- Finally, evaluate the results!
    maybe
      (do
        maybe'
          (\_ ->
            fromMaybe
              (pure do
                P.parseFailed i pos
                    "The impossible happened. Failure without error")
              (do
                es <- losers
                pure case es of
                  e:es | null es || not (null i) -> do
                    pure (P.Result e.input (Left e.result.error) e.consumed e.position)
                  otherwise -> pure $ P.parseFailed i pos ""
              )
          )
          (\r ->  do
            State.modify (_ { done = r.result.done })
            pure $ P.Result r.input
                            (Right r.result.value)
                            r.consumed
                            r.position
          )
          winner
      )
      (\x ->
        let err = unParseError (x.result.error)
         in pure $ P.parseFailedFatal i pos err.message
      )
      fatal

-- Terminate the parser at the given argument and collect all subsequent
-- values int an array ("options-first" and "stop-at")
terminate :: D.Argument -> Parser Value
terminate arg = do
  input <- getInput
  let rest = ArrayValue $ toUnfoldable $ StringValue <<< Token.getSource <$> input
  markDone
  modifyDepth (const 99999)
  P.ParserT \(P.PState _ pos) -> pure (P.Result Nil (Right rest) true pos)

isFrom :: Origin -> RichValue -> Boolean
isFrom o rv = o == RValue.getOrigin rv

unParseError :: P.ParseError -> { position :: P.Position, message :: String, fatal :: Boolean }
unParseError (P.ParseError message position fatal) = { message, position, fatal }

mapWithIndex' = flip mapWithIndex

-- Clump together arguments to aid parsing "invisible" subgroups, where
-- arguments may appear in any order, for example. "Fixed" argument lists
-- are parsed in fixed order, whereas "Free" argument lists, can be parsed in
-- any order.
clump
  :: List D.Argument -- ^ the list of arguments to clump
  -> Boolean         -- ^ allow lax placement?
  -> Boolean         -- ^ are we parsing options first?
  -> List (Clump (List D.Argument))
clump xs lax optsFirst = reverse $ foldl go Nil xs
  where
  go (Nil) x = pure $ (if isFree x then Free else Fixed) $ singleton x
  go   ((Free a) :zs) x | isFree x = (Free (a <> (singleton x))) : zs
  go u@((Free _) :_ ) x = (Fixed $ singleton x) : u
  go u@((Fixed _):_ ) x | isFree x = (Free $ singleton x): u
  go   ((Fixed a):zs) x = (Fixed (a <> (singleton x))) : zs
  isFree x = (lax || D.isFree x) && (not (optsFirst && isTerm x))

-- Note: Unfortunate re-implementation of the 'Alt' instance for 'ParserT'.
catchParseError :: ∀ a. Parser a -> (P.ParseError -> Parser a) -> Parser a
catchParseError p1 f2 = P.ParserT \st ->
  P.unParserT p1 st >>= \(o@(P.Result input result consumed pos)) ->
    case result of
      Left (P.ParseError _ _ true) -> pure o
      Left e | not consumed        -> P.unParserT (f2 e) st
      otherwise                    -> pure o

termAs :: D.Argument -> Maybe D.Argument
termAs (D.Group (grp@{ branches: (x@(D.Positional pos):Nil) : Nil }))
  | pos.repeatable || grp.repeatable = Just x
termAs x@(D.Positional pos) | pos.repeatable = Just x
termAs _ = Nothing

isTerm :: D.Argument -> Boolean
isTerm = isJust <<< termAs


Also export size

Also export size

module Servant.Subscriber.Subscriptions (
    Subscriptions
  , makeSubscriptions
  , diffSubscriptions
  , toList
  , size
  ) where

import Prelude

import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Control.Monad.Eff (Eff)
import Control.Monad.ST (ST)
import Data.Function.Uncurried (runFn4)
import Data.Generic (gShow)
import Data.List (List(Nil, Cons))
import Data.Monoid (class Monoid)
import Data.StrMap (StrMap, foldM)
import Data.StrMap.ST (STStrMap)
import Servant.Subscriber.Internal (_lookup, mutate, ToUserType, Subscription)
import Servant.Subscriber.Request (HttpRequest)

newtype Subscriptions a = Subscriptions (StrMap (Subscription a))

makeSubscriptions :: forall a. HttpRequest -> ToUserType a -> Subscriptions a
makeSubscriptions req' parser = Subscriptions $ StrMap.singleton (gShow req')
    {
      req : req'
    , parseResponses : Cons parser Nil
    }

toList :: forall a. Subscriptions a -> List (Subscription a)
toList (Subscriptions a) = StrMap.values a

-- | Number of subscriptions
size :: forall a. Subscriptions a -> Number
size (Subscriptions m) = StrMap.size m

mergeParsers :: forall a. Subscription a -> Subscription a -> Subscription a
mergeParsers subA subB = subA {
    parseResponses = subA.parseResponses <> subB.parseResponses
  }

mergeStrMap :: forall a. StrMap (Subscription a) -> StrMap (Subscription a) -> StrMap (Subscription a)
mergeStrMap m1 m2 = mutate (\s1 -> foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> mergeParsers v1 v2) k m2)) s1 m1) m2

instance semigroupSubscriptions :: Semigroup (Subscriptions a) where
  append (Subscriptions a) (Subscriptions b) = Subscriptions $ mergeStrMap a b

instance monoidSubscriptions :: Monoid (Subscriptions a) where
  mempty = Subscriptions $ StrMap.empty

instance functorSubscriptions :: Functor Subscriptions where
  map f (Subscriptions a) = Subscriptions $ map (mapSubscription f) a

-- | Calculates the items which are in the first map but not in the second.
--   In other words: All elements present in the second map will be removed from the first.
diffSubscriptions :: forall a. Subscriptions a -> Subscriptions a -> Subscriptions a
diffSubscriptions (Subscriptions a) (Subscriptions b) = Subscriptions $ diffMaps a b

-- | Calculates the items which are in the first map but not in the second.
--   In other words: All elements present in the second map will be removed from the first.
diffMaps :: forall a. StrMap a -> StrMap a -> StrMap a
diffMaps a b = (mutate (\a' -> StrMap.foldM deleteItem a' b)) a
  where
    deleteItem :: forall x h r. STStrMap h x -> String -> x -> Eff (st :: ST h | r) (STStrMap h x)
    deleteItem m key _ = SM.delete m key

mapSubscription :: forall a b. (a -> b) -> Subscription a -> Subscription b
mapSubscription f orig = orig {  parseResponses  = map (map f) <$> orig.parseResponses }

module Servant.Subscriber.Subscriptions (
    Subscriptions
  , makeSubscriptions
  , diffSubscriptions
  , toList
  ) where

import Prelude

import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Control.Monad.Eff (Eff)
import Control.Monad.ST (ST)
import Data.Function.Uncurried (runFn4)
import Data.Generic (gShow)
import Data.List (List(Nil, Cons))
import Data.Monoid (class Monoid)
import Data.StrMap (StrMap, foldM)
import Data.StrMap.ST (STStrMap)
import Servant.Subscriber.Internal (_lookup, mutate, ToUserType, Subscription)
import Servant.Subscriber.Request (HttpRequest)

newtype Subscriptions a = Subscriptions (StrMap (Subscription a))

makeSubscriptions :: forall a. HttpRequest -> ToUserType a -> Subscriptions a
makeSubscriptions req' parser = Subscriptions $ StrMap.singleton (gShow req')
    {
      req : req'
    , parseResponses : Cons parser Nil
    }

toList :: forall a. Subscriptions a -> List (Subscription a)
toList (Subscriptions a) = StrMap.values a

-- | Number of subscriptions
size :: forall a. Subscriptions a -> Number
size (Subscriptions m) = StrMap.size m

mergeParsers :: forall a. Subscription a -> Subscription a -> Subscription a
mergeParsers subA subB = subA {
    parseResponses = subA.parseResponses <> subB.parseResponses
  }

mergeStrMap :: forall a. StrMap (Subscription a) -> StrMap (Subscription a) -> StrMap (Subscription a)
mergeStrMap m1 m2 = mutate (\s1 -> foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> mergeParsers v1 v2) k m2)) s1 m1) m2

instance semigroupSubscriptions :: Semigroup (Subscriptions a) where
  append (Subscriptions a) (Subscriptions b) = Subscriptions $ mergeStrMap a b

instance monoidSubscriptions :: Monoid (Subscriptions a) where
  mempty = Subscriptions $ StrMap.empty

instance functorSubscriptions :: Functor Subscriptions where
  map f (Subscriptions a) = Subscriptions $ map (mapSubscription f) a

-- | Calculates the items which are in the first map but not in the second.
--   In other words: All elements present in the second map will be removed from the first.
diffSubscriptions :: forall a. Subscriptions a -> Subscriptions a -> Subscriptions a
diffSubscriptions (Subscriptions a) (Subscriptions b) = Subscriptions $ diffMaps a b

-- | Calculates the items which are in the first map but not in the second.
--   In other words: All elements present in the second map will be removed from the first.
diffMaps :: forall a. StrMap a -> StrMap a -> StrMap a
diffMaps a b = (mutate (\a' -> StrMap.foldM deleteItem a' b)) a
  where
    deleteItem :: forall x h r. STStrMap h x -> String -> x -> Eff (st :: ST h | r) (STStrMap h x)
    deleteItem m key _ = SM.delete m key

mapSubscription :: forall a b. (a -> b) -> Subscription a -> Subscription b
mapSubscription f orig = orig {  parseResponses  = map (map f) <$> orig.parseResponses }


add a content container

add a content container

module Main where

import Data.Maybe

import qualified Thermite as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T
import qualified Thermite.Events as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T

import Models.Action
import Models.Channel
import Models.Group
import Models.Input
import Models.User
import Models.Message
import Models.State
import Views.Channel
import Views.Input
import Views.Message

spec :: T.Spec (T.Action _ State) State Unit Action
spec = T.Spec
	{ displayName : Just "chatty"
	, render: render
	, performAction: performAction
	, initialState: initialState
	, componentWillMount: Nothing
	}

testUser2 :: User
testUser2 = { name: "Ron", email: "ron@potter.com" }

render :: T.Render State Unit Action
render ctx st _ =
	container
		[ header [ E.h1' [ H.text "Chatty" ] ]
		, contentContainer
			[ channelsView ctx st.channels
			, messagesView st.selectedChannel st.messages
			, messageInput ctx st
			]
		]
	where
		container = E.div [ A.className "container" ]
		contentContainer = E.div [ A.className "content-container" ]
		header = E.div [ A.className "header" ]

performAction :: T.PerformAction Unit Action (T.Action _ State)
performAction _ action =
	case action of
		SendMessage sendMessage ->
			T.modifyState \st ->
				st { messages =
						st.messages <> [ { from: st.user, to: testUser2, message: TextMessage { text: sendMessage } } ]
					, editText = ""
				}
		SetEditText setEditText ->
			T.modifyState \st ->
				st { editText = setEditText }
		SelectChannel channel ->
			T.modifyState \st ->
				st { selectedChannel = channel }
		SelectInputType inputType ->
			T.modifyState \st ->
				st { selectedInputType = inputType }
		DoNothing ->
			T.modifyState id

initialState :: State
initialState =
	{ messages: [ ]
	, editText: ""
	, user:
		{ name: "Harry"
		, email: "harry@potter.com"
		}
	, channels: [ { name: "Haskell" }, { name: "Purescript" } ]
	, selectedChannel: { name: "Haskell" }
	, selectedInputType: TextInput
	}

main = do
	let cl = T.createClass spec
	T.render cl unit

module Main where

import Data.Maybe

import qualified Thermite as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T
import qualified Thermite.Events as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T

import Models.Action
import Models.Channel
import Models.Group
import Models.Input
import Models.User
import Models.Message
import Models.State
import Views.Channel
import Views.Input
import Views.Message

spec :: T.Spec (T.Action _ State) State Unit Action
spec = T.Spec
	{ displayName : Just "chatty"
	, render: render
	, performAction: performAction
	, initialState: initialState
	, componentWillMount: Nothing
	}

testUser2 :: User
testUser2 = { name: "Ron", email: "ron@potter.com" }

render :: T.Render State Unit Action
render ctx st _ =
	container
		[ header [ E.h1' [ H.text "Chatty" ] ]
		, channelsView ctx st.channels
		, messagesView st.selectedChannel st.messages
		, messageInput ctx st
		]
	where
		container = E.div [ A.className "container" ]
		header = E.div [ A.className "header" ]

performAction :: T.PerformAction Unit Action (T.Action _ State)
performAction _ action =
	case action of
		SendMessage sendMessage ->
			T.modifyState \st ->
				st { messages =
						st.messages <> [ { from: st.user, to: testUser2, message: TextMessage { text: sendMessage } } ]
					, editText = ""
				}
		SetEditText setEditText ->
			T.modifyState \st ->
				st { editText = setEditText }
		SelectChannel channel ->
			T.modifyState \st ->
				st { selectedChannel = channel }
		SelectInputType inputType ->
			T.modifyState \st ->
				st { selectedInputType = inputType }
		DoNothing ->
			T.modifyState id

initialState :: State
initialState =
	{ messages: [ ]
	, editText: ""
	, user:
		{ name: "Harry"
		, email: "harry@potter.com"
		}
	, channels: [ { name: "Haskell" }, { name: "Purescript" } ]
	, selectedChannel: { name: "Haskell" }
	, selectedInputType: TextInput
	}

main = do
	let cl = T.createClass spec
	T.render cl unit


Add type signature

Add type signature

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.Node.Document

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  w  <- window
  hd <- document w
  let d  = htmlDocumentToDocument hd
  u  <- url d
  log $ "Wow! " ++ show u

module Main where

import Prelude
import Control.Monad.Eff.Console
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.Node.Document

main = do
  w  <- window
  hd <- document w
  let d  = htmlDocumentToDocument hd
  u  <- url d
  log $ "Wow! " ++ show u


8.19.2  Instead of using a ul element to show the validation errors in a list, modify the code to create one div with the alert style for each error.

module Data.AddressBook.UI where

import Prelude

import DOM

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.AddressBook
import Data.AddressBook.Validation
import Data.Traversable (sequence)

import Control.Bind

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Console

valueOf :: forall eff. String -> Eff (dom :: DOM | eff) String
valueOf sel = do
  maybeEl <- querySelector sel
  case maybeEl of
    Nothing -> return ""
    Just el -> do
      value <- getValue el
      return $ case read value of
        Right s -> s
        _ -> ""

displayValidationErrors :: forall eff. Array String -> Eff (dom :: DOM | eff) Unit
displayValidationErrors errs = do
  alert <- createElement "div"

  foreachE errs $ \err -> do
    div <- createElement "div" >>= setText err
    addClass "alert" div
    addClass "alert-danger" div
    div `appendChild` alert
    return unit

  Just validationErrors <- querySelector "#validationErrors"
  alert `appendChild` validationErrors

  return unit

validateControls :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) (Either (Array String) Person)
validateControls = do
  log "Running validators"

  p <- person <$> valueOf "#inputFirstName"
              <*> valueOf "#inputLastName"
              <*> (address <$> valueOf "#inputStreet"
                           <*> valueOf "#inputCity"
                           <*> valueOf "#inputState")
              <*> sequence [ phoneNumber HomePhone <$> valueOf "#inputHomePhone"
                           , phoneNumber CellPhone <$> valueOf "#inputCellPhone"
                           , phoneNumber WorkPhone <$> valueOf "#inputWorkPhone"
                           ]

  return $ validatePerson' p

validateAndUpdateUI :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
validateAndUpdateUI = do
  Just validationErrors <- querySelector "#validationErrors"
  setInnerHTML "" validationErrors

  errorsOrResult <- validateControls

  case errorsOrResult of
    Left errs -> displayValidationErrors errs
    Right result -> print result

  return unit

setupEventHandlers :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
setupEventHandlers = do
  -- Listen for changes on form fields
  body >>= addEventListener "change" validateAndUpdateUI

  return unit

module Data.AddressBook.UI where

import Prelude

import DOM

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.AddressBook
import Data.AddressBook.Validation
import Data.Traversable (sequence)

import Control.Bind

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Console

valueOf :: forall eff. String -> Eff (dom :: DOM | eff) String
valueOf sel = do
  maybeEl <- querySelector sel
  case maybeEl of
    Nothing -> return ""
    Just el -> do
      value <- getValue el
      return $ case read value of
        Right s -> s
        _ -> ""

displayValidationErrors :: forall eff. Array String -> Eff (dom :: DOM | eff) Unit
displayValidationErrors errs = do
  alert <- createElement "div"
    >>= addClass "alert"
    >>= addClass "alert-danger"

  ul <- createElement "ul"
  ul `appendChild` alert

  foreachE errs $ \err -> do
    li <- createElement "li" >>= setText err
    li `appendChild` ul
    return unit

  Just validationErrors <- querySelector "#validationErrors"
  alert `appendChild` validationErrors

  return unit

validateControls :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) (Either (Array String) Person)
validateControls = do
  log "Running validators"

  p <- person <$> valueOf "#inputFirstName"
              <*> valueOf "#inputLastName"
              <*> (address <$> valueOf "#inputStreet"
                           <*> valueOf "#inputCity"
                           <*> valueOf "#inputState")
              <*> sequence [ phoneNumber HomePhone <$> valueOf "#inputHomePhone"
                           , phoneNumber CellPhone <$> valueOf "#inputCellPhone"
                           , phoneNumber WorkPhone <$> valueOf "#inputWorkPhone"
                           ]

  return $ validatePerson' p

validateAndUpdateUI :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
validateAndUpdateUI = do
  Just validationErrors <- querySelector "#validationErrors"
  setInnerHTML "" validationErrors

  errorsOrResult <- validateControls

  case errorsOrResult of
    Left errs -> displayValidationErrors errs
    Right result -> print result

  return unit

setupEventHandlers :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
setupEventHandlers = do
  -- Listen for changes on form fields
  body >>= addEventListener "change" validateAndUpdateUI

  return unit