Fix `...` being limited two 2

Fix `...` being limited two 2

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , initialState
  , Parser ()
  , StateObj ()
  , RichValue (..)
  , RichValueObj (..)
  , ValueMapping ()
  , unRichValue
  , from
  ) where

import Prelude
import Control.Plus (empty)
import Control.Bind ((=<<))
import Debug.Trace
import Control.Apply ((<*), (*>))
import Data.Function (on)
import Data.Bifunctor
import Data.Either (Either(..), either, isRight)
import Data.Maybe (Maybe(..), maybe, fromMaybe, maybe', isNothing)
import Data.List (List(..), foldM, reverse, singleton, concat, length, (:),
                  some, filter, head, fromList, sortBy, groupBy, last, null)
import Control.Alt ((<|>))
import Data.Traversable (traverse)
import Control.Lazy (defer)
import Control.Monad (when, unless)
import Control.MonadPlus (guard)
import Data.Foldable (all, intercalate, maximumBy, sum, any, for_, foldl)
import Data.String as String
import Data.String (fromChar, fromCharArray, stripPrefix)
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(..), fst, snd)
import Control.Monad.Reader (ask)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State, evalState)
import Control.Monad.State as State
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Text.Parsing.Parser (PState(..), ParseError(..), ParserT(..), fail,
                            parseFailed, unParserT) as P
import Text.Parsing.Parser.Combinators (option, try, lookAhead, (<?>)) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P

import Language.Docopt.Argument (Argument(..), Branch(..), isFree, runBranch,
                                prettyPrintArg, prettyPrintArgNaked,
                                hasEnvBacking, getArgument, hasDefault,
                                isRepeatable, isFlag, setRequired) as D
import Language.Docopt.Usage (Usage, runUsage) as D
import Language.Docopt.Env (Env ())
import Language.Docopt.Env as Env
import Language.Docopt.Option as O
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.Parser.Base (getInput)
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.Token (PositionedToken(..), Token(..),
                                        unPositionedToken, prettyPrintToken)
import Data.String.Ext (startsWith)

debug :: Boolean
debug = false

-- | The value type the parser collects
type RichValueObj = {
  value  :: Value
, origin :: Origin
}

newtype RichValue = RichValue RichValueObj

instance showRichValue :: Show RichValue where
  show (RichValue v) = "RichValue { origin: " ++ show v.origin
                    ++ ", value: " ++ show v.value ++ "}"

instance eqRichValue :: Eq RichValue where
  eq (RichValue v) (RichValue v') = (v.origin == v'.origin) &&
                                    (v.value == v'.value)

unRichValue :: RichValue -> RichValueObj
unRichValue (RichValue o) = o

from :: Origin -> Value -> RichValue
from o v = RichValue $ { value: v, origin: o }

fromArgv :: Value -> RichValue
fromArgv = from Origin.Argv

-- | The output value mappings of arg -> val
type ValueMapping = Tuple D.Argument RichValue

-- | The stateful parser type
type StateObj = { depth :: Int
                , fatal :: Maybe P.ParseError }
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT Env (State StateObj))
                          a

initialState :: StateObj
initialState = { depth: 0
               , fatal: Nothing }

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

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

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

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (BoolValue true)
    go _                = Nothing

positional :: String -> Parser Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (Value.read v false)
    go _       = Nothing

stdin :: Parser Value
stdin = token go P.<?> "stdin flag"
  where
    go Stdin = Just (BoolValue true)
    go _     = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, sourcePos: npos, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks npos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v' -> singleton $ PositionedToken {
                                                  token:     v'
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | (not isFlag) && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (Value.read s false) Nothing false
          _  -> case atok of
            Just (Lit s) -> return $ OptParse (Value.read s false)  Nothing true
            otherwise    ->
              if (fromMaybe true (_.optional <<< O.runArgument <$> a))
                 then Right $ OptParse (BoolValue true) Nothing false
                 else Left  $ "Option requires argument: --" ++ n'

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' v) _ | isFlag && (n' == n)
      = case v of
             Just _  -> Left $ "Option takes no argument: --" ++ n'
             Nothing -> return $ OptParse (BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) _ | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s false) Nothing false
          _      -> Left "Invalid substring"

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

shortOption :: Char -> (Maybe O.Argument) -> Parser Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) -> do
  return $ case toks of
    Cons (PositionedToken { token: tok, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:
              let
                pushed = maybe empty
                                (\v' ->
                                  singleton
                                    $ PositionedToken
                                        { token:     v'
                                        , sourcePos: pos
                                        , source:    "-" ++ String.drop 2 s
                                        })
                                newtok
                rest = if hasConsumedArg then LU.tail xs else xs
              in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && (not isFlag) && (A.null xs)
      = case v of
          Just s    -> return $ OptParse (Value.read s false) Nothing false
          otherwise -> case atok of
            Just (Lit s) -> return $ OptParse (Value.read s false) Nothing true
            otherwise    ->
              if (fromMaybe true (_.optional <<< O.runArgument <$> a))
                 then Right $ OptParse (BoolValue true) Nothing false
                 else  Left $ "Option requires argument: -" ++ fromChar f'

    -- case 2:
    -- The leading flag matches, there are stacked options, a explicit
    -- argument may have been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (not $ A.null xs)
      = do
        let arg = fromCharArray xs ++ maybe "" ("=" ++ _) v
        return $ OptParse (Value.read arg false)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (not $ A.null xs)
      = return $ OptParse (BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.null xs)
      = case v of
              Just _  -> Left $ "Option takes no argument: -" ++ fromChar f'
              Nothing -> return $ OptParse (BoolValue true)
                                            Nothing
                                            false

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    (Cons (PositionedToken {token: tok, source}) _) ->
      P.parseFailed s pos
        $ case tok of
              LOpt _ _   -> "Unmatched option: " ++ source
              SOpt _ _ _ -> "Unmatched option: " ++ source
              EOA _      -> "Unmatched option: --"
              Stdin      -> "Unmatched option: -"
              Lit _      -> "Unmatched command: " ++ source

-- | Generate a parser for a single program usage.
genUsageParser :: List D.Usage -- ^ The list of usage specs
               -> Boolean      -- ^ Enable "options-first"
               -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser xs optsFirst = do
    genBranchesParser (concat $ D.runUsage <$> xs)
                      true
                      optsFirst
                      true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs term optsFirst canSkip
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env   :: Env      <- ask
    state :: StateObj <- lift State.get

    let
      ps = xs <#> \x -> (Tuple x) <$> do
                          genBranchParser x optsFirst canSkip
                            <* unless (not term) eof
      rs  = evalState (runReaderT (collect s ps) env) initialState
      rs' = reverse rs

      -- Evaluate the winning candidates, if any.
      -- First, sort the positive results by their depth, then group consecutive
      -- elements, take the highest element and sort the inner values by their
      -- fallback score.
      winner =
          maximumBy (compare `on`
                      (((_.origin <<< unRichValue <<< snd) <$> _) <<< snd
                        <<< _.value <<< _.result)) =<< do
                          last $ groupBy (eq `on` (_.depth <<< _.result))
                                  (sortBy (compare `on` (_.depth <<< _.result))
                                          (mrights rs'))

      -- Evaluate the losing candidates, if any.
      losers =
          last $ groupBy (eq `on` (_.depth <<< _.result))
                         (sortBy (compare `on` (_.depth <<< _.result))
                                 (mlefts rs))

    maybe'
      (\_ ->
        fromMaybe
          (return do
            P.parseFailed i pos
                "The impossible happened. Failure without error")
          (do
            es <- losers
            return case es of
              Cons e es | null es || not (null i) -> do
                when ((startsWith
                        "Option takes no argument"
                        (unParseError e.result.error).message)
                    || (startsWith
                        "Option requires argument"
                        (unParseError e.result.error).message)) do
                          lift $ State.modify (_ {  fatal = Just e.result.error })
                return $ e { result = Left e.result.error }
              otherwise -> return $ P.parseFailed i pos ""
          )
      )
      (\r -> return $ r { result = Right r.result.value })
      winner

  where
  fixMessage m = m
  collect s ps = ps `flip traverse` \p -> do

    o                 <- P.unParserT p s
    state :: StateObj <- lift State.get

    -- If any parse encountered a fatal error, fail with that error.
    -- XXX: this approach is pragmatic and works around not being able to catch
    --      errors in purescript-parsing. Ideally, this would not be needed.
    --      Also, using "o" is actually misleading here as it claims the error
    --      happened at a different location as to where it actually
    --      did. This has no impact atm on the way neodoc works, but is
    --      something to keep in mind.
    flip fromMaybe
      (do
        e <- state.fatal
        return
          $ return
            $ Left
              -- XXX: use a huge depth for fatal errors to be bubbled
              --      up properly (be selected). Again, this is due to
              --      insufficient control over handling fatal vs.
              --      non-fatal errors.
              $ o { result = { error: e, depth: 99999 } }
      )
      (return $ bimap
        (\e -> o { result = { error: e, depth: state.depth } })
        (\r -> o { result = { value: r, depth: state.depth } })
        o.result)

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- ^ The branch to match
                -> Boolean   -- ^ Enable "options-first"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (List ValueMapping)
genBranchParser (D.Branch xs) optsFirst canSkip = do
  modifyDepth (const 0) -- reset the depth counter
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument -- ^ The free arguments
                        -> Boolean         -- ^ Can we skip input via fallbacks?
                        -> Parser (List ValueMapping)
    genExhaustiveParser Nil canSkip = return mempty
    genExhaustiveParser ps  canSkip = do
      if debug
        then do
          traceA $ "genExhaustiveParser: "
                ++ (intercalate " " (D.prettyPrintArg <$> ps))
                ++ " - canSkip: " ++  show canSkip
          else return unit
      draw ps (length ps) Nil

      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> List D.Argument -- ^ the unique arguments parsed
             -> Parser (List ValueMapping)

        draw pss@(Cons p ps') n tot | n >= 0 = (do
          when debug do
            i <- getInput
            traceA $
              "draw: (" ++ (D.prettyPrintArg p) ++ ":"
                        ++ (intercalate ":" (D.prettyPrintArg <$> ps'))
                        ++  ") - n: " ++ show n
                        ++ "from input: "
                        ++ (intercalate " " (prettyPrintToken
                                              <<< _.token
                                              <<< unPositionedToken <$> i))

          -- Generate the parser for the argument `p`. 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
          r <- P.try $ genParser (D.setRequired p true) (not $ n > 0)

          r' <- P.try do
                  if D.isRepeatable p
                        then draw pss (length pss) (p:tot)
                        else draw ps' (length ps') (p:tot)

          return $ r ++ r'
        ) <|> (defer \_ -> do
              state :: StateObj <- lift State.get
              case state.fatal of
                Just (P.ParseError { message }) -> P.fail message
                otherwise -> draw (ps' ++ singleton p) (n - 1) tot
              )

        draw ps' n tot | (length ps' > 0) && (n < 0) = do
          env :: StrMap String <- lift ask

          let
            vs = ps' <#> \o ->
              maybe
                (Left o)
                (Right <<< Tuple o)
                do
                  (RichValue v) <- do
                    guard (canSkip || (length ps' < length ps))
                    (getEnvValue env o <#> from Origin.Environment) <|>
                    (getDefaultValue o <#> from Origin.Default)     <|>
                    (getEmptyValue   o <#> from Origin.Empty)

                  return $ RichValue v {
                    value = if D.isRepeatable o
                                then ArrayValue $ Value.intoArray v.value
                                else v.value
                  }

            missing   = filter (not <<< isSkippable) (mlefts vs)
            fallbacks = mrights vs

          if canSkip
             then do
              xs <- genExhaustiveParser missing false
              return $ fallbacks ++ xs
             else
              if (length missing > 0)
                then P.fail $
                  "Expected option(s): "
                    ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
                else return fallbacks

          where
          isSkippable (D.Group o bs _)
              = o || (all (all isSkippable <<< D.runBranch) bs)
          isSkippable o = D.isRepeatable o && (any (_ == o) tot)

          getEnvValue :: Env -> D.Argument -> Maybe Value
          getEnvValue env (D.Option (O.Option o@{ env: Just k })) = do
            StringValue <$> Env.lookup k env
          getEnvValue _ _ = Nothing

          getDefaultValue :: D.Argument -> Maybe Value
          getDefaultValue (D.Option (O.Option o@{
              arg: Just (O.Argument { default: Just v })
            })) = return if o.repeatable
                            then ArrayValue $ Value.intoArray v
                            else v
          getDefaultValue _ = Nothing

          getEmptyValue :: D.Argument -> Maybe Value
          getEmptyValue = go
            where
            go (D.Option (O.Option o@{ arg: Nothing }))
              = return
                  $ if o.repeatable then ArrayValue []
                                    else BoolValue false
            go (D.Option (O.Option o@{ arg: Just (O.Argument { optional: true }) }))
              = return
                  $ if o.repeatable then ArrayValue []
                                    else BoolValue false
            go (D.Positional _ r) | r = return $ ArrayValue []
            go (D.Command _ r)    | r = return $ ArrayValue []
            go (D.Stdin)              = return $ BoolValue false
            go (D.EOA)                = return $ ArrayValue []
            go _                      = Nothing

        draw _ _ _ = return mempty

    step :: Acc (List ValueMapping)
         -> D.Argument
         -> Either P.ParseError (Acc (List ValueMapping))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    -- "Free" groups always transition to the `Pending state`
    step (Free p) x@(D.Group _ _ _) | D.isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x false
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _)
      = return $ Pending p (x:xs)

    -- "Free" groups always keep accumulating
    step (Pending p xs) x@(D.Group _ _ _) | D.isFree x
      = return $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs true
        rss <- genParser y false
        return $ r ++ rs ++ rss

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <<< fromArgv <$> do
                  StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return rest
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> Parser (List ValueMapping)

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) _ = do
      i <- getInput
      (do
        if r then (some go) else (singleton <$> go)
      ) <|> (P.fail $ "Expected " ++ D.prettyPrintArg x ++ butGot i)
        where go = do Tuple x <<< fromArgv <$> (do
                        v <- command n
                        return if r then ArrayValue $ Value.intoArray v
                                    else v
                      )
                      <* modifyDepth (_ + 1)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) _ = do
      singleton <<< Tuple x <<< fromArgv <$> (do
        eoa <|> (return $ ArrayValue []) -- XXX: Fix type
        <* modifyDepth (_ + 1)
      ) <|> P.fail "Expected \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) _ = do
      singleton <<< Tuple x <<< fromArgv <$> (do
        stdin
        <* modifyDepth (_ + 1)
      ) <|> P.fail "Expected \"-\""

    genParser x@(D.Positional n r) _
      | r && optsFirst
      = terminate x

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) _ = do
      i <- getInput
      (do
        if r then (some go) else (singleton <$> go)
      ) <|> P.fail ("Expected " ++ D.prettyPrintArg x ++ butGot i)
        where go = do Tuple x <<< fromArgv <$> (do
                        v <- positional n
                        return if r then ArrayValue $ Value.intoArray v
                                    else v
                        )
                      <* modifyDepth (_ + 1)

    genParser x@(D.Group optional bs r) _
      | optsFirst && (length bs == 1) &&
        all (\(D.Branch xs) ->
          case xs of
            Cons (D.Positional n r') Nil -> r' || r
            _                            -> false
        ) bs
      = terminate (LU.head (D.runBranch (LU.head bs)))

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) _ = (do
      do
        if o.repeatable then (some go) else (singleton <$> go)
      <* modifyDepth (_ + 1)
      )
        where
          go = 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).
            isLopt <- P.option false (P.lookAhead $ P.try $ token isAnyLopt)
            isSopt <- P.option false (P.lookAhead $ P.try $ token isAnySopt)
            P.ParserT \s -> do
              o <- P.unParserT (if isLopt
                then P.try do
                  Tuple x <<< fromArgv <$> (do
                    v <- mkLoptParser o.name o.arg
                    return if o.repeatable then ArrayValue $ Value.intoArray v
                                           else v
                  )
                else if isSopt
                  then P.try do
                    Tuple x <<< fromArgv <$> (do
                      v <- mkSoptParser o.flag o.arg
                      return if o.repeatable then ArrayValue $ Value.intoArray v
                                            else v
                    )
                  else P.fail "long or short option") s
              case o.result of
                  (Left e) -> do
                    when ((startsWith
                            "Option takes no argument"
                            (unParseError e).message)
                       || (startsWith
                            "Option requires argument"
                            (unParseError e).message)) do
                              lift $ State.modify (_ { fatal = Just e })
                    return o
                  otherwise -> return o

          isAnyLopt (LOpt _ _) = return true
          isAnyLopt _          = return false

          isAnySopt (SOpt _ _ _) = return true
          isAnySopt _            = return false

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) canSkip =
      let mod = if optional then P.option mempty <<< P.try else \p -> p
       in mod go
      where
        go | length bs == 0 = return mempty
        go = do
          x <- step
          if repeated && length x > 0
             then do
                xs <- go <|> return mempty
                return $ x ++ xs
             else return x

        step = snd <$> do
                genBranchesParser bs
                                  false
                                  optsFirst
                                  -- always allow skipping for non-free groups.
                                  (not (D.isFree x) || canSkip)

    butGot :: List PositionedToken -> String
    butGot (Cons (PositionedToken { source }) _) = ", but got " ++ source
    butGot Nil                                   = ""

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

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , initialState
  , Parser ()
  , StateObj ()
  , RichValue (..)
  , RichValueObj (..)
  , ValueMapping ()
  , unRichValue
  , from
  ) where

import Prelude
import Control.Plus (empty)
import Control.Bind ((=<<))
import Debug.Trace
import Control.Apply ((<*), (*>))
import Data.Function (on)
import Data.Bifunctor
import Data.Either (Either(..), either, isRight)
import Data.Maybe (Maybe(..), maybe, fromMaybe, maybe', isNothing)
import Data.List (List(..), foldM, reverse, singleton, concat, length, (:),
                  some, filter, head, fromList, sortBy, groupBy, last, null)
import Control.Alt ((<|>))
import Data.Traversable (traverse)
import Control.Lazy (defer)
import Control.Monad (when, unless)
import Control.MonadPlus (guard)
import Data.Foldable (all, intercalate, maximumBy, sum, any, for_, foldl)
import Data.String as String
import Data.String (fromChar, fromCharArray, stripPrefix)
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(..), fst, snd)
import Control.Monad.Reader (ask)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State, evalState)
import Control.Monad.State as State
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Text.Parsing.Parser (PState(..), ParseError(..), ParserT(..), fail,
                            parseFailed, unParserT) as P
import Text.Parsing.Parser.Combinators (option, try, lookAhead, (<?>)) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P

import Language.Docopt.Argument (Argument(..), Branch(..), isFree, runBranch,
                                prettyPrintArg, prettyPrintArgNaked,
                                hasEnvBacking, getArgument, hasDefault,
                                isRepeatable, isFlag, setRequired) as D
import Language.Docopt.Usage (Usage, runUsage) as D
import Language.Docopt.Env (Env ())
import Language.Docopt.Env as Env
import Language.Docopt.Option as O
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.Parser.Base (getInput)
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.Token (PositionedToken(..), Token(..),
                                        unPositionedToken, prettyPrintToken)
import Data.String.Ext (startsWith)

debug :: Boolean
debug = false

-- | The value type the parser collects
type RichValueObj = {
  value  :: Value
, origin :: Origin
}

newtype RichValue = RichValue RichValueObj

instance showRichValue :: Show RichValue where
  show (RichValue v) = "RichValue { origin: " ++ show v.origin
                    ++ ", value: " ++ show v.value ++ "}"

instance eqRichValue :: Eq RichValue where
  eq (RichValue v) (RichValue v') = (v.origin == v'.origin) &&
                                    (v.value == v'.value)

unRichValue :: RichValue -> RichValueObj
unRichValue (RichValue o) = o

from :: Origin -> Value -> RichValue
from o v = RichValue $ { value: v, origin: o }

fromArgv :: Value -> RichValue
fromArgv = from Origin.Argv

-- | The output value mappings of arg -> val
type ValueMapping = Tuple D.Argument RichValue

-- | The stateful parser type
type StateObj = { depth :: Int
                , fatal :: Maybe P.ParseError }
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT Env (State StateObj))
                          a

initialState :: StateObj
initialState = { depth: 0
               , fatal: Nothing }

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

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

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

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (BoolValue true)
    go _                = Nothing

positional :: String -> Parser Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (Value.read v false)
    go _       = Nothing

stdin :: Parser Value
stdin = token go P.<?> "stdin flag"
  where
    go Stdin = Just (BoolValue true)
    go _     = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, sourcePos: npos, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks npos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v' -> singleton $ PositionedToken {
                                                  token:     v'
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | (not isFlag) && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (Value.read s false) Nothing false
          _  -> case atok of
            Just (Lit s) -> return $ OptParse (Value.read s false)  Nothing true
            otherwise    ->
              if (fromMaybe true (_.optional <<< O.runArgument <$> a))
                 then Right $ OptParse (BoolValue true) Nothing false
                 else Left  $ "Option requires argument: --" ++ n'

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' v) _ | isFlag && (n' == n)
      = case v of
             Just _  -> Left $ "Option takes no argument: --" ++ n'
             Nothing -> return $ OptParse (BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) _ | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s false) Nothing false
          _      -> Left "Invalid substring"

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

shortOption :: Char -> (Maybe O.Argument) -> Parser Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) -> do
  return $ case toks of
    Cons (PositionedToken { token: tok, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:
              let
                pushed = maybe empty
                                (\v' ->
                                  singleton
                                    $ PositionedToken
                                        { token:     v'
                                        , sourcePos: pos
                                        , source:    "-" ++ String.drop 2 s
                                        })
                                newtok
                rest = if hasConsumedArg then LU.tail xs else xs
              in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && (not isFlag) && (A.null xs)
      = case v of
          Just s    -> return $ OptParse (Value.read s false) Nothing false
          otherwise -> case atok of
            Just (Lit s) -> return $ OptParse (Value.read s false) Nothing true
            otherwise    ->
              if (fromMaybe true (_.optional <<< O.runArgument <$> a))
                 then Right $ OptParse (BoolValue true) Nothing false
                 else  Left $ "Option requires argument: -" ++ fromChar f'

    -- case 2:
    -- The leading flag matches, there are stacked options, a explicit
    -- argument may have been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (not $ A.null xs)
      = do
        let arg = fromCharArray xs ++ maybe "" ("=" ++ _) v
        return $ OptParse (Value.read arg false)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (not $ A.null xs)
      = return $ OptParse (BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.null xs)
      = case v of
              Just _  -> Left $ "Option takes no argument: -" ++ fromChar f'
              Nothing -> return $ OptParse (BoolValue true)
                                            Nothing
                                            false

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    (Cons (PositionedToken {token: tok, source}) _) ->
      P.parseFailed s pos
        $ case tok of
              LOpt _ _   -> "Unmatched option: " ++ source
              SOpt _ _ _ -> "Unmatched option: " ++ source
              EOA _      -> "Unmatched option: --"
              Stdin      -> "Unmatched option: -"
              Lit _      -> "Unmatched command: " ++ source

-- | Generate a parser for a single program usage.
genUsageParser :: List D.Usage -- ^ The list of usage specs
               -> Boolean      -- ^ Enable "options-first"
               -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser xs optsFirst = do
    genBranchesParser (concat $ D.runUsage <$> xs)
                      true
                      optsFirst
                      true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs term optsFirst canSkip
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env   :: Env      <- ask
    state :: StateObj <- lift State.get

    let
      ps = xs <#> \x -> (Tuple x) <$> do
                          genBranchParser x optsFirst canSkip
                            <* unless (not term) eof
      rs  = evalState (runReaderT (collect s ps) env) initialState
      rs' = reverse rs

      -- Evaluate the winning candidates, if any.
      -- First, sort the positive results by their depth, then group consecutive
      -- elements, take the highest element and sort the inner values by their
      -- fallback score.
      winner =
          maximumBy (compare `on`
                      (((_.origin <<< unRichValue <<< snd) <$> _) <<< snd
                        <<< _.value <<< _.result)) =<< do
                          last $ groupBy (eq `on` (_.depth <<< _.result))
                                  (sortBy (compare `on` (_.depth <<< _.result))
                                          (mrights rs'))

      -- Evaluate the losing candidates, if any.
      losers =
          last $ groupBy (eq `on` (_.depth <<< _.result))
                         (sortBy (compare `on` (_.depth <<< _.result))
                                 (mlefts rs))

    maybe'
      (\_ ->
        fromMaybe
          (return do
            P.parseFailed i pos
                "The impossible happened. Failure without error")
          (do
            es <- losers
            return case es of
              Cons e es | null es || not (null i) -> do
                when ((startsWith
                        "Option takes no argument"
                        (unParseError e.result.error).message)
                    || (startsWith
                        "Option requires argument"
                        (unParseError e.result.error).message)) do
                          lift $ State.modify (_ {  fatal = Just e.result.error })
                return $ e { result = Left e.result.error }
              otherwise -> return $ P.parseFailed i pos ""
          )
      )
      (\r -> return $ r { result = Right r.result.value })
      winner

  where
  fixMessage m = m
  collect s ps = ps `flip traverse` \p -> do

    o                 <- P.unParserT p s
    state :: StateObj <- lift State.get

    -- If any parse encountered a fatal error, fail with that error.
    -- XXX: this approach is pragmatic and works around not being able to catch
    --      errors in purescript-parsing. Ideally, this would not be needed.
    --      Also, using "o" is actually misleading here as it claims the error
    --      happened at a different location as to where it actually
    --      did. This has no impact atm on the way neodoc works, but is
    --      something to keep in mind.
    flip fromMaybe
      (do
        e <- state.fatal
        return
          $ return
            $ Left
              -- XXX: use a huge depth for fatal errors to be bubbled
              --      up properly (be selected). Again, this is due to
              --      insufficient control over handling fatal vs.
              --      non-fatal errors.
              $ o { result = { error: e, depth: 99999 } }
      )
      (return $ bimap
        (\e -> o { result = { error: e, depth: state.depth } })
        (\r -> o { result = { value: r, depth: state.depth } })
        o.result)

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- ^ The branch to match
                -> Boolean   -- ^ Enable "options-first"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (List ValueMapping)
genBranchParser (D.Branch xs) optsFirst canSkip = do
  modifyDepth (const 0) -- reset the depth counter
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument -- ^ The free arguments
                        -> Boolean         -- ^ Can we skip input via fallbacks?
                        -> Parser (List ValueMapping)
    genExhaustiveParser Nil canSkip = return mempty
    genExhaustiveParser ps  canSkip = do
      if debug
        then do
          traceA $ "genExhaustiveParser: "
                ++ (intercalate " " (D.prettyPrintArg <$> ps))
                ++ " - canSkip: " ++  show canSkip
          else return unit
      draw ps (length ps) Nil

      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> List D.Argument -- ^ the unique arguments parsed
             -> Parser (List ValueMapping)

        draw pss@(Cons p ps') n tot | n >= 0 = (do
          when debug do
            i <- getInput
            traceA $
              "draw: (" ++ (D.prettyPrintArg p) ++ ":"
                        ++ (intercalate ":" (D.prettyPrintArg <$> ps'))
                        ++  ") - n: " ++ show n
                        ++ "from input: "
                        ++ (intercalate " " (prettyPrintToken
                                              <<< _.token
                                              <<< unPositionedToken <$> i))

          -- Generate the parser for the argument `p`. 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
          r <- P.try $ genParser (D.setRequired p true) (not $ n > 0)

          r' <- P.try do
                  if D.isRepeatable p
                        then draw pss (length pss) (p:tot)
                        else draw ps' (length ps') (p:tot)

          return $ r ++ r'
        ) <|> (defer \_ -> do
              state :: StateObj <- lift State.get
              case state.fatal of
                Just (P.ParseError { message }) -> P.fail message
                otherwise -> draw (ps' ++ singleton p) (n - 1) tot
              )

        draw ps' n tot | (length ps' > 0) && (n < 0) = do
          env :: StrMap String <- lift ask

          let
            vs = ps' <#> \o ->
              maybe
                (Left o)
                (Right <<< Tuple o)
                do
                  (RichValue v) <- do
                    guard (canSkip || (length ps' < length ps))
                    (getEnvValue env o <#> from Origin.Environment) <|>
                    (getDefaultValue o <#> from Origin.Default)     <|>
                    (getEmptyValue   o <#> from Origin.Empty)

                  return $ RichValue v {
                    value = if D.isRepeatable o
                                then ArrayValue $ Value.intoArray v.value
                                else v.value
                  }

            missing   = filter (not <<< isSkippable) (mlefts vs)
            fallbacks = mrights vs

          if canSkip
             then do
              xs <- genExhaustiveParser missing false
              return $ fallbacks ++ xs
             else
              if (length missing > 0)
                then P.fail $
                  "Expected option(s): "
                    ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
                else return fallbacks

          where
          isSkippable (D.Group o bs _)
              = o || (all (all isSkippable <<< D.runBranch) bs)
          isSkippable o = D.isRepeatable o && (any (_ == o) tot)

          getEnvValue :: Env -> D.Argument -> Maybe Value
          getEnvValue env (D.Option (O.Option o@{ env: Just k })) = do
            StringValue <$> Env.lookup k env
          getEnvValue _ _ = Nothing

          getDefaultValue :: D.Argument -> Maybe Value
          getDefaultValue (D.Option (O.Option o@{
              arg: Just (O.Argument { default: Just v })
            })) = return if o.repeatable
                            then ArrayValue $ Value.intoArray v
                            else v
          getDefaultValue _ = Nothing

          getEmptyValue :: D.Argument -> Maybe Value
          getEmptyValue = go
            where
            go (D.Option (O.Option o@{ arg: Nothing }))
              = return
                  $ if o.repeatable then ArrayValue []
                                    else BoolValue false
            go (D.Option (O.Option o@{ arg: Just (O.Argument { optional: true }) }))
              = return
                  $ if o.repeatable then ArrayValue []
                                    else BoolValue false
            go (D.Positional _ r) | r = return $ ArrayValue []
            go (D.Command _ r)    | r = return $ ArrayValue []
            go (D.Stdin)              = return $ BoolValue false
            go (D.EOA)                = return $ ArrayValue []
            go _                      = Nothing

        draw _ _ _ = return mempty

    step :: Acc (List ValueMapping)
         -> D.Argument
         -> Either P.ParseError (Acc (List ValueMapping))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    -- "Free" groups always transition to the `Pending state`
    step (Free p) x@(D.Group _ _ _) | D.isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x false
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _)
      = return $ Pending p (x:xs)

    -- "Free" groups always keep accumulating
    step (Pending p xs) x@(D.Group _ _ _) | D.isFree x
      = return $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs true
        rss <- genParser y false
        return $ r ++ rs ++ rss

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <<< fromArgv <$> do
                  StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return rest
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> Parser (List ValueMapping)

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) _ = do
      i <- getInput
      (do
        if r then (some go) else (singleton <$> go)
      ) <|> (P.fail $ "Expected " ++ D.prettyPrintArg x ++ butGot i)
        where go = do Tuple x <<< fromArgv <$> (do
                        v <- command n
                        return if r then ArrayValue $ Value.intoArray v
                                    else v
                      )
                      <* modifyDepth (_ + 1)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) _ = do
      singleton <<< Tuple x <<< fromArgv <$> (do
        eoa <|> (return $ ArrayValue []) -- XXX: Fix type
        <* modifyDepth (_ + 1)
      ) <|> P.fail "Expected \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) _ = do
      singleton <<< Tuple x <<< fromArgv <$> (do
        stdin
        <* modifyDepth (_ + 1)
      ) <|> P.fail "Expected \"-\""

    genParser x@(D.Positional n r) _
      | r && optsFirst
      = terminate x

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) _ = do
      i <- getInput
      (do
        if r then (some go) else (singleton <$> go)
      ) <|> P.fail ("Expected " ++ D.prettyPrintArg x ++ butGot i)
        where go = do Tuple x <<< fromArgv <$> (do
                        v <- positional n
                        return if r then ArrayValue $ Value.intoArray v
                                    else v
                        )
                      <* modifyDepth (_ + 1)

    genParser x@(D.Group optional bs r) _
      | optsFirst && (length bs == 1) &&
        all (\(D.Branch xs) ->
          case xs of
            Cons (D.Positional n r') Nil -> r' || r
            _                            -> false
        ) bs
      = terminate (LU.head (D.runBranch (LU.head bs)))

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) _ = (do
      do
        if o.repeatable then (some go) else (singleton <$> go)
      <* modifyDepth (_ + 1)
      )
        where
          go = 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).
            isLopt <- P.option false (P.lookAhead $ P.try $ token isAnyLopt)
            isSopt <- P.option false (P.lookAhead $ P.try $ token isAnySopt)
            P.ParserT \s -> do
              o <- P.unParserT (if isLopt
                then P.try do
                  Tuple x <<< fromArgv <$> (do
                    v <- mkLoptParser o.name o.arg
                    return if o.repeatable then ArrayValue $ Value.intoArray v
                                           else v
                  )
                else if isSopt
                  then P.try do
                    Tuple x <<< fromArgv <$> (do
                      v <- mkSoptParser o.flag o.arg
                      return if o.repeatable then ArrayValue $ Value.intoArray v
                                            else v
                    )
                  else P.fail "long or short option") s
              case o.result of
                  (Left e) -> do
                    when ((startsWith
                            "Option takes no argument"
                            (unParseError e).message)
                       || (startsWith
                            "Option requires argument"
                            (unParseError e).message)) do
                              lift $ State.modify (_ { fatal = Just e })
                    return o
                  otherwise -> return o

          isAnyLopt (LOpt _ _) = return true
          isAnyLopt _          = return false

          isAnySopt (SOpt _ _ _) = return true
          isAnySopt _            = return false

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) canSkip =
      let mod = if optional then P.option mempty <<< P.try else \p -> p
       in mod go
      where
        go | length bs == 0 = return mempty
        go = do
          x <- step
          if repeated && length x > 0
             then do
                xs <- step <|> return mempty
                return $ x ++ xs
             else return x

        step = snd <$> do
                genBranchesParser bs
                                  false
                                  optsFirst
                                  -- always allow skipping for non-free groups.
                                  (not (D.isFree x) || canSkip)

    butGot :: List PositionedToken -> String
    butGot (Cons (PositionedToken { source }) _) = ", but got " ++ source
    butGot Nil                                   = ""

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


fix TodoServer example

fix TodoServer example

module ToDoServer where

import Prelude hiding (apply)
import Data.Maybe
import Data.Array (range, zipWith, length)
import Data.Foreign.EasyFFI
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (CONSOLE(), log)
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Node.Express.Types
import Node.Express.App
import Node.Express.Handler
import Node.HTTP (Server())

-- Pretend for now that this is our cool database (:
todos :: Array Todo
todos = []

foreign import data DB :: !

type Todo = { desc :: String, isDone :: Boolean }
type IndexedTodo = { id :: Number, desc :: String, isDone :: Boolean }

addTodo :: forall e. Array Todo -> Todo -> Eff (db :: DB | e) Number
addTodo =
    unsafeForeignFunction ["todos", "todo", ""]
    "todos.push(todo) - 1"

updateTodo :: forall e. Array Todo -> Number -> String -> Eff (db :: DB | e) Unit
updateTodo =
    unsafeForeignProcedure ["todos", "id", "newDesc", ""]
    "(todos[id] || {}).desc = newDesc;"

deleteTodo :: forall e. Array Todo -> Number -> Eff (db :: DB | e) Unit
deleteTodo =
    unsafeForeignProcedure ["todos", "id", ""]
    "todos.splice(id, 1);"

setDone :: forall e. Array Todo -> Number -> Eff (db :: DB | e) Unit
setDone =
    unsafeForeignProcedure ["todos", "id", ""]
    "(todos[id] || {}).isDone = true;"

getTodosWithIndexes :: forall e. Array Todo -> Eff (db :: DB | e) (Array IndexedTodo)
getTodosWithIndexes =
    unsafeForeignFunction ["todos", ""]
    "todos.map(function(t,i) { return { id: i, desc: t.desc, isDone: t.isDone }; });"

parseNumber :: String -> Number
parseNumber = unsafeForeignFunction ["str"] "parseInt(str);"

logger :: forall e. Handler (console :: CONSOLE | e)
logger = do
    url <- getOriginalUrl
    liftEff $ log (">>> " ++ url)
    next

errorHandler :: forall e. Error -> Handler e
errorHandler err = do
    setStatus 400
    sendJson {error: message err}

help = { name: "Todo example"
       , purpose: "To present a subset of purescript-express package capabilities"
       , howToUse:
            { listTodos: "/list"
            , createTodo: "/create?desc=Do+something"
            , doTodo: "/done/:id"
            , updateTodo: "/update/:id?desc=Do+something+else"
            , deleteTodo: "/delete/:id"
            }
       , forkMe: "https://github.com/dancingrobot84/purescript-express"
       }

indexHandler :: forall e. Handler e
indexHandler = sendJson help

listTodosHandler :: forall e. Handler (db :: DB | e)
listTodosHandler = do
    indexedTodos <- liftEff $ getTodosWithIndexes todos
    sendJson indexedTodos

createTodoHandler :: forall e. Handler (db :: DB | e)
createTodoHandler = do
    descParam <- getQueryParam "desc"
    case descParam of
        Nothing -> nextThrow $ error "Description is required"
        Just desc -> do
            newId <- liftEff $ addTodo todos { desc: desc, isDone: false }
            sendJson {status: "Created", id: newId}

updateTodoHandler :: forall e. Handler (db :: DB | e)
updateTodoHandler = do
    idParam <- getRouteParam "id"
    descParam <- getQueryParam "desc"
    case [idParam, descParam] of
        [Just id, Just desc] -> do
            liftEff $ updateTodo todos (parseNumber id) desc
            sendJson {status: "Updated"}
        _ -> nextThrow $ error "Id and Description are required"

deleteTodoHandler :: forall e. Handler (db :: DB | e)
deleteTodoHandler = do
    idParam <- getRouteParam "id"
    case idParam of
        Nothing -> nextThrow $ error "Id is required"
        Just id -> do
            liftEff $ deleteTodo todos (parseNumber id)
            sendJson {status: "Deleted"}

doTodoHandler :: forall e. Handler (db :: DB | e)
doTodoHandler = do
    idParam <- getRouteParam "id"
    case idParam of
        Nothing -> nextThrow $ error "Id is required"
        Just id -> do
            liftEff $ setDone todos (parseNumber id)
            sendJson {status: "Done"}

appSetup :: forall e. App (db :: DB, console :: CONSOLE | e)
appSetup = do
    liftEff $ log "Setting up"
    setProp "json spaces" 4.0
    use logger
    get "/" indexHandler
    get "/list" listTodosHandler
    get "/create" createTodoHandler
    get "/update/:id" updateTodoHandler
    get "/delete/:id" deleteTodoHandler
    get "/done/:id" doTodoHandler
    useOnError errorHandler

main :: forall e. Eff (db :: DB, express :: EXPRESS, console :: CONSOLE | e) Server
main = do
    port <- unsafeForeignFunction [""] "process.env.PORT || 8080"
    listenHttp appSetup port \_ ->
        log $ "Listening on " ++ show port

module ToDoServer where

import Prelude hiding (apply)
import Data.Maybe
import Data.Array (range, zipWith, length)
import Data.Foreign.EasyFFI
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (CONSOLE(), log)
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Node.Express.Types
import Node.Express.App
import Node.Express.Handler
import Node.HTTP (Server())

-- Pretend for now that this is our cool database (:
todos :: Array Todo
todos = []

foreign import data DB :: !

type Todo = { desc :: String, isDone :: Boolean }
type IndexedTodo = { id :: Number, desc :: String, isDone :: Boolean }

addTodo :: forall e. Array Todo -> Todo -> Eff (db :: DB | e) Number
addTodo =
    unsafeForeignFunction ["todos", "todo", ""]
    "todos.push(todo) - 1"

updateTodo :: forall e. Array Todo -> Number -> String -> Eff (db :: DB | e) Unit
updateTodo =
    unsafeForeignProcedure ["todos", "id", "newDesc", ""]
    "(todos[id] || {}).desc = newDesc;"

deleteTodo :: forall e. Array Todo -> Number -> Eff (db :: DB | e) Unit
deleteTodo =
    unsafeForeignProcedure ["todos", "id", ""]
    "todos.splice(id, 1);"

setDone :: forall e. Array Todo -> Number -> Eff (db :: DB | e) Unit
setDone =
    unsafeForeignProcedure ["todos", "id", ""]
    "(todos[id] || {}).isDone = true;"

getTodosWithIndexes :: forall e. Array Todo -> Eff (db :: DB | e) (Array IndexedTodo)
getTodosWithIndexes =
    unsafeForeignFunction ["todos", ""]
    "todos.map(function(t,i) { return { id: i, desc: t.desc, isDone: t.isDone }; });"

parseNumber :: String -> Number
parseNumber = unsafeForeignFunction ["str"] "parseInt(str);"

logger :: forall e. Handler e
logger = do
    url <- getOriginalUrl
    liftEff $ log (">>> " ++ url)
    next

errorHandler :: forall e. Error -> Handler e
errorHandler err = do
    setStatus 400
    sendJson {error: message err}

help = { name: "Todo example"
       , purpose: "To present a subset of purescript-express package capabilities"
       , howToUse:
            { listTodos: "/list"
            , createTodo: "/create?desc=Do+something"
            , doTodo: "/done/:id"
            , updateTodo: "/update/:id?desc=Do+something+else"
            , deleteTodo: "/delete/:id"
            }
       , forkMe: "https://github.com/dancingrobot84/purescript-express"
       }

indexHandler :: forall e. Handler e
indexHandler = sendJson help

listTodosHandler :: forall e. Handler e
listTodosHandler = do
    indexedTodos <- liftEff $ getTodosWithIndexes todos
    sendJson indexedTodos

createTodoHandler :: forall e. Handler e
createTodoHandler = do
    descParam <- getQueryParam "desc"
    case descParam of
        Nothing -> nextThrow $ error "Description is required"
        Just desc -> do
            newId <- liftEff $ addTodo todos { desc: desc, isDone: false }
            sendJson {status: "Created", id: newId}

updateTodoHandler :: forall e. Handler e
updateTodoHandler = do
    idParam <- getRouteParam "id"
    descParam <- getQueryParam "desc"
    case [idParam, descParam] of
        [Just id, Just desc] -> do
            liftEff $ updateTodo todos (parseNumber id) desc
            sendJson {status: "Updated"}
        _ -> nextThrow $ error "Id and Description are required"

deleteTodoHandler :: forall e. Handler e
deleteTodoHandler = do
    idParam <- getRouteParam "id"
    case idParam of
        Nothing -> nextThrow $ error "Id is required"
        Just id -> do
            liftEff $ deleteTodo todos (parseNumber id)
            sendJson {status: "Deleted"}

doTodoHandler :: forall e. Handler e
doTodoHandler = do
    idParam <- getRouteParam "id"
    case idParam of
        Nothing -> nextThrow $ error "Id is required"
        Just id -> do
            liftEff $ setDone todos (parseNumber id)
            sendJson {status: "Done"}

appSetup :: forall e. App e
appSetup = do
    liftEff $ log "Setting up"
    setProp "json spaces" 4.0
    use logger
    get "/" indexHandler
    get "/list" listTodosHandler
    get "/create" createTodoHandler
    get "/update/:id" updateTodoHandler
    get "/delete/:id" deleteTodoHandler
    get "/done/:id" doTodoHandler
    useOnError errorHandler

main :: forall e. Eff (express :: EXPRESS, console :: CONSOLE | e) Server
main = do
    port <- unsafeForeignFunction [""] "process.env.PORT || 8080"
    listenHttp appSetup port \_ ->
        log $ "Listening on " ++ show port


Changed reading/writing memory functions, and changed initial memory state

module MainMem where

import Prelude
import Math
import Data.Sequence as S
import Data.Maybe
import Data.Foldable
import Data.Int.Bits
import Data.Array as A
import Data.Tuple as T

import Gpu
import Types
import Utils

--NOTE: optimization:
--Most of the memory is not writable, so consider
--saving it in a javascript array.
--But let that be transparent behind the reading/writing
--functions interface, i.e. decide where to read from depending
--on the address that is given as input.

-- 8 Bit version

setRom :: Array I8 -> MainMem -> MainMem
setRom rom (MainMem mem) = MainMem $ mem { rom = rom }

--NOTE: toggle biosMapped when pc == 0x0100
rd8 :: I16 -> MainMem -> I8
rd8 addr (MainMem {biosMapped,bios,rom,eram,wram,zram, gpu = gpu@{vram,oam}}) =
  case 0xF000.&.addr of
    0x0000 -> if biosMapped && (addr < 0x0100)
             then fromMaybe 0 $ bios A.!! addr -- NOTE log error
             else fromMaybe 0 $ rom A.!! addr -- NOTE log error
    n | 0x1000 <= n && n <= 0x7000 -> fromMaybe 0 $ rom A.!! addr -- NOTE log err
    0x8000 -> vram !! (0x1FFF .&. addr)
    0x9000 -> vram !! (0x1FFF .&. addr)
    0xA000 -> eram !! (0x1FFF .&. addr)
    0xB000 -> eram !! (0x1FFF .&. addr)
    0xC000 -> wram !! (0x1FFF .&. addr)
    0xD000 -> wram !! (0x1FFF .&. addr)
    0xE000 -> wram !! (0x1FFF .&. addr)
    0xF000 ->
      case 0x0F00.&.addr of
        n | n < 0x0E00 -> wram !! (0x1FFF .&. addr)
        0x0E00 ->
          if addr < 0xFEA0 then oam !! (0xFF .&. addr) else 0
        0x0F00 ->
          case 0x00F0.&.addr of
            n | n >= 0x0080 -> zram !! (0x7F .&. addr)
            n | 0x0040 <= n && n <= 0x0070 -> gpuRd8 addr gpu
            --TODO temporary until key input is implemented
            0x00 -> if addr == 0xFF00 then 0xDF else -1
            otherwise -> -1 --NOTE log this
        otherwise -> -1 --NOTE log this
    otherwise -> -1 --NOTE log this

--NOTE: make sure the significant byte part sits at a higher address
rd16 :: I16 -> MainMem -> I16
rd16 addr mem = (h `shl` 8) + l
 where
  l = rd8 addr mem
  h = rd8 (addr + 1) mem

--NOTE: temporary implementation. Writing to parts that are not writable
--memory during execution should be treated with an error.
--The initial writing to them should be ST array computations,
--and not wr8 calls
wr8 :: I8 -> I16 -> MainMem -> MainMem
wr8 i8 addr (MainMem mem@{biosMapped,bios,rom,eram,wram,zram,gpu=gpu@{oam}}) =
  MainMem $ modifyMem mem
 where
  modifyMem =
    case 0xF000.&.addr of
      n | 0 <= n && n <= 7 -> id -- NOTE error can't write to bios or rom
      --{ vram = S.replace i8 (0x1FFF .&. addr) vram }
      0x8000 -> _ { gpu  = wrVRam i8 addr gpu }
      0x9000 -> _ { gpu  = wrVRam i8 addr gpu }
      0xA000 -> _ { eram = S.replace i8 (0x1FFF .&. addr) eram }
      0xB000 -> _ { eram = S.replace i8 (0x1FFF .&. addr) eram }
      0xC000 -> _ { wram = S.replace i8 (0x1FFF .&. addr) wram }
      0xD000 -> _ { wram = S.replace i8 (0x1FFF .&. addr) wram }
      0xE000 -> _ { wram = S.replace i8 (0x1FFF .&. addr) wram }
      0xF000 ->
        case 0x0F00.&.addr of
          n | n < 0x0E00 -> _ { wram = S.replace i8 (0x1FFF .&. addr) wram }
          0x0E00 ->
            if addr < 0xFEA0
              then _ { gpu = gpu { oam = S.replace i8 (0xFF .&. addr) oam } }
              else id --NOTE unwritable, log this
          0x0F00 ->
            case 0x00F0.&.addr of
              n | n >= 0x0080 -> _ { zram = S.replace i8 (0x7F .&. addr) zram }
              n | 0x0040 <= n && n <= 0x0070 -> _ { gpu = gpuWr8 i8 addr gpu }
              otherwise -> id --NOTE log this
          otherwise -> id --NOTE log this
      otherwise -> id --NOTE log this

wr16 :: I16 -> I16 -> MainMem -> MainMem
wr16 i16 addr mem =
      wr8 h (addr + 1)
  <<< wr8 l addr
   $  mem
 where
  h = 255 .&. (i16 `zshr` 8)
  l = 255 .&. i16

cleanMainMem :: MainMem
cleanMainMem = initIOArea $ MainMem
  { biosMapped : false
  , rom  : A.singleton 0
  , eram : S.fromFoldable $ A.replicate 8192 0xFF
  , wram : S.fromFoldable $ A.replicate 8192  0
  , zram : S.fromFoldable $ A.replicate 128 0
  , gpu  : cleanGpu
  , bios :  [
    0x31, 0xFE, 0xFF, 0xAF, 0x21, 0xFF, 0x9F, 0x32,
    0xCB, 0x7C, 0x20, 0xFB, 0x21, 0x26, 0xFF, 0x0E,
    0x11, 0x3E, 0x80, 0x32, 0xE2, 0x0C, 0x3E, 0xF3,
    0xE2, 0x32, 0x3E, 0x77, 0x77, 0x3E, 0xFC, 0xE0,
    0x47, 0x11, 0x04, 0x01, 0x21, 0x10, 0x80, 0x1A,
    0xCD, 0x95, 0x00, 0xCD, 0x96, 0x00, 0x13, 0x7B,
    0xFE, 0x34, 0x20, 0xF3, 0x11, 0xD8, 0x00, 0x06,
    0x08, 0x1A, 0x13, 0x22, 0x23, 0x05, 0x20, 0xF9,
    0x3E, 0x19, 0xEA, 0x10, 0x99, 0x21, 0x2F, 0x99,
    0x0E, 0x0C, 0x3D, 0x28, 0x08, 0x32, 0x0D, 0x20,
    0xF9, 0x2E, 0x0F, 0x18, 0xF3, 0x67, 0x3E, 0x64,
    0x57, 0xE0, 0x42, 0x3E, 0x91, 0xE0, 0x40, 0x04,
    0x1E, 0x02, 0x0E, 0x0C, 0xF0, 0x44, 0xFE, 0x90,
    0x20, 0xFA, 0x0D, 0x20, 0xF7, 0x1D, 0x20, 0xF2,
    0x0E, 0x13, 0x24, 0x7C, 0x1E, 0x83, 0xFE, 0x62,
    0x28, 0x06, 0x1E, 0xC1, 0xFE, 0x64, 0x20, 0x06,
    0x7B, 0xE2, 0x0C, 0x3E, 0x87, 0xF2, 0xF0, 0x42,
    0x90, 0xE0, 0x42, 0x15, 0x20, 0xD2, 0x05, 0x20,
    0x4F, 0x16, 0x20, 0x18, 0xCB, 0x4F, 0x06, 0x04,
    0xC5, 0xCB, 0x11, 0x17, 0xC1, 0xCB, 0x11, 0x17,
    0x05, 0x20, 0xF5, 0x22, 0x23, 0x22, 0x23, 0xC9,
    0xCE, 0xED, 0x66, 0x66, 0xCC, 0x0D, 0x00, 0x0B,
    0x03, 0x73, 0x00, 0x83, 0x00, 0x0C, 0x00, 0x0D,
    0x00, 0x08, 0x11, 0x1F, 0x88, 0x89, 0x00, 0x0E,
    0xDC, 0xCC, 0x6E, 0xE6, 0xDD, 0xDD, 0xD9, 0x99,
    0xBB, 0xBB, 0x67, 0x63, 0x6E, 0x0E, 0xEC, 0xCC,
    0xDD, 0xDC, 0x99, 0x9F, 0xBB, 0xB9, 0x33, 0x3E,
    0x3c, 0x42, 0xB9, 0xA5, 0xB9, 0xA5, 0x42, 0x4C,
    0x21, 0x04, 0x01, 0x11, 0xA8, 0x00, 0x1A, 0x13,
    0xBE, 0x20, 0xFE, 0x23, 0x7D, 0xFE, 0x34, 0x20,
    0xF5, 0x06, 0x19, 0x78, 0x86, 0x23, 0x05, 0x20,
    0xFB, 0x86, 0x20, 0xFE, 0x3E, 0x01, 0xE0, 0x50
  ]
  }
 where
  ioMem = A.zip (0xFF00 A... 0xFF7F) [
    0xCF,0x00,0x7E,0xFF,0xAF,0x00,0x00,0xF8,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xFF,0xE1,
    0x80,0xBF,0xF3,0xFF,0xBF,0xFF,0x3F,0x00,0xFF,0xBF,0x7F,0xFF,0x9F,0xFF,0xBF,0xFF,
    0xFF,0x00,0x00,0xBF,0x77,0xF3,0xF1,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
    0x06,0xFE,0x0E,0x7F,0x00,0xFF,0x58,0xDF,0x00,0xEC,0x00,0xBF,0x0C,0xED,0x03,0xF7,
    0x91,0x85,0x00,0x00,0x00,0x00,0x00,0xFC,0xFF,0xFF,0x00,0x00,0xFF,0x7E,0xFF,0xFE,
    0xFF,0x00,0x00,0x00,0x00,0xFF,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
    0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xC0,0x00,0xC1,0x00,0x00,0x00,0x00,0x00,
    0xF8,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00
  ]
  initIOArea mm = foldl (\acc (T.Tuple addr b) -> wr8 b addr acc) mm ioMem

getGpu :: MainMem -> Gpu
getGpu (MainMem mm) = mm.gpu

setGpu :: Gpu -> MainMem -> MainMem
setGpu gpu' (MainMem mm) = MainMem $ mm { gpu = gpu' }

module MainMem where

import Prelude
import Math
import Data.Sequence as S
import Data.Maybe
import Data.Int.Bits
import Data.Array as A

import Types

-- 8 Bit version

-- 8 Bit version

setRom :: Array I8 -> MainMem -> MainMem
setRom rom (MainMem mem) = MainMem $ mem { rom = rom }

--NOTE: toggle inbios when pc == 0x0100
rd8 :: I16 -> MainMem -> I8
rd8 addr (MainMem mem) =
  fromMaybe 0 $ S.index addr mem

--NOTE make sure the significant byte part sits at a higher address
rd16 :: I16 -> MainMem -> I16
rd16 addr (MainMem mem) = (h `shl` 8) + l
 where
  l = fromMaybe 0 $ S.index addr mem
  h = fromMaybe 0 $ S.index (addr + 1) mem

wr8 :: I8 -> I16 -> MainMem -> MainMem
wr8 i8 addr (MainMem mem) = MainMem $ S.replace i8 addr mem

wr16 :: I16 -> I16 -> MainMem -> MainMem
wr16 i16 addr (MainMem mem) = MainMem $
      S.replace h (addr + 1)
  <<< S.replace l addr
   $  mem
 where
  h = 255 .&. (i16 `zshr` 8)
  l = 255 .&. i16

--16 Bit version

--NOTE consider splitting the mems to a generic number of chunks N
--that you can easily change, and then profile the performance for different N
--Or consider using array ST, if in need of better performance

--memory address
{--0 1 2 3 4 ...--}
{--0 0 1 1 2 ...--}
--seq index

{--the quotient is the index--}
{--the remainder is the offset inside the chunk--}
--Chunk size in bytes
{--chkSz :: Int--}
{--chkSz = 2--}

{--cleanMainMem :: MainMem--}
{--cleanMainMem = MainMem $ S.fromFoldable $ A.replicate size 0--}
 {--where--}
  {--size = 65536 / chkSz--}

{--rd8 :: I16 -> MainMem -> I8--}
{--rd8 addr (MainMem mem) = lsByteOf $--}
  {--(if isShiftNeeded then shiftByte else id) i16--}
 {--where--}
  {--isShiftNeeded = addr `mod` 2 == 0--}
  {--i16 = fromMaybe 0 $ S.index (addr / chkSz) mem--}
  {--shiftByte x = x `zshr` 8--}
  {--lsByteOf x = x .&. 255--}

{----NOTE replace all 'fromMaybe's with an error mechanism that will make it easy--}
{----to trace Nothing cases--}
{--rd16 :: I16 -> MainMem -> I16--}
{--rd16 addr (MainMem mem) = fromMaybe 0 $ S.index (addr / chkSz) mem--}

{--wr8 :: I8 -> I16 -> MainMem -> MainMem--}
{--wr8 i8 addr (MainMem mem) = MainMem $ S.adjust adjByte (addr / chkSz) mem--}
 {--where--}
  {--adjByte = (_ .|. i8') <<<--}
    {--(_ .&. if isShiftNeeded then 255 else 65535 - 255)--}
  {--i8' = (if isShiftNeeded then shiftByte else id) i8--}
  {--isShiftNeeded = addr `mod` 2 == 0--}
  {--shiftByte x = x `shl` 8--}

{--wr16 :: I16 -> I16 -> MainMem -> MainMem--}
{--wr16 i16 addr (MainMem mem) = MainMem $ S.replace i16 (addr / chkSz) mem--}
cleanMainMem :: MainMem
cleanMainMem = initMem $ MainMem
  { biosMapped : false
  , rom  : A.singleton 0
  , eram : S.fromFoldable $ A.replicate 8192 0
  , wram : S.fromFoldable $ A.replicate 8192  0
  , zram : S.fromFoldable $ A.replicate 128 0
  , gpu  : cleanGpu
  , bios :  [
    0x31, 0xFE, 0xFF, 0xAF, 0x21, 0xFF, 0x9F, 0x32,
    0xCB, 0x7C, 0x20, 0xFB, 0x21, 0x26, 0xFF, 0x0E,
    0x11, 0x3E, 0x80, 0x32, 0xE2, 0x0C, 0x3E, 0xF3,
    0xE2, 0x32, 0x3E, 0x77, 0x77, 0x3E, 0xFC, 0xE0,
    0x47, 0x11, 0x04, 0x01, 0x21, 0x10, 0x80, 0x1A,
    0xCD, 0x95, 0x00, 0xCD, 0x96, 0x00, 0x13, 0x7B,
    0xFE, 0x34, 0x20, 0xF3, 0x11, 0xD8, 0x00, 0x06,
    0x08, 0x1A, 0x13, 0x22, 0x23, 0x05, 0x20, 0xF9,
    0x3E, 0x19, 0xEA, 0x10, 0x99, 0x21, 0x2F, 0x99,
    0x0E, 0x0C, 0x3D, 0x28, 0x08, 0x32, 0x0D, 0x20,
    0xF9, 0x2E, 0x0F, 0x18, 0xF3, 0x67, 0x3E, 0x64,
    0x57, 0xE0, 0x42, 0x3E, 0x91, 0xE0, 0x40, 0x04,
    0x1E, 0x02, 0x0E, 0x0C, 0xF0, 0x44, 0xFE, 0x90,
    0x20, 0xFA, 0x0D, 0x20, 0xF7, 0x1D, 0x20, 0xF2,
    0x0E, 0x13, 0x24, 0x7C, 0x1E, 0x83, 0xFE, 0x62,
    0x28, 0x06, 0x1E, 0xC1, 0xFE, 0x64, 0x20, 0x06,
    0x7B, 0xE2, 0x0C, 0x3E, 0x87, 0xF2, 0xF0, 0x42,
    0x90, 0xE0, 0x42, 0x15, 0x20, 0xD2, 0x05, 0x20,
    0x4F, 0x16, 0x20, 0x18, 0xCB, 0x4F, 0x06, 0x04,
    0xC5, 0xCB, 0x11, 0x17, 0xC1, 0xCB, 0x11, 0x17,
    0x05, 0x20, 0xF5, 0x22, 0x23, 0x22, 0x23, 0xC9,
    0xCE, 0xED, 0x66, 0x66, 0xCC, 0x0D, 0x00, 0x0B,
    0x03, 0x73, 0x00, 0x83, 0x00, 0x0C, 0x00, 0x0D,
    0x00, 0x08, 0x11, 0x1F, 0x88, 0x89, 0x00, 0x0E,
    0xDC, 0xCC, 0x6E, 0xE6, 0xDD, 0xDD, 0xD9, 0x99,
    0xBB, 0xBB, 0x67, 0x63, 0x6E, 0x0E, 0xEC, 0xCC,
    0xDD, 0xDC, 0x99, 0x9F, 0xBB, 0xB9, 0x33, 0x3E,
    0x3c, 0x42, 0xB9, 0xA5, 0xB9, 0xA5, 0x42, 0x4C,
    0x21, 0x04, 0x01, 0x11, 0xA8, 0x00, 0x1A, 0x13,
    0xBE, 0x20, 0xFE, 0x23, 0x7D, 0xFE, 0x34, 0x20,
    0xF5, 0x06, 0x19, 0x78, 0x86, 0x23, 0x05, 0x20,
    0xFB, 0x86, 0x20, 0xFE, 0x3E, 0x01, 0xE0, 0x50
  ]
  }
 where
  initMem =
          wr8 0xD8 0xCFF7
      <<< wr8 0xD8 0xEFF7
      <<< wr8 0x80 0xCFFB
      <<< wr8 0x80 0xEFFB
      <<< wr8 0x3B 0xCFFD
      <<< wr8 0x3B 0xEFFD
      <<< wr8 0x03 0xCFFE
      <<< wr8 0x03 0xEFFE

      <<< wr8 0x03 0xDF78

      <<< wr8 0x80 0xFF40
      <<< wr8 0x87 0xFF41
      <<< wr8 0xE4 0xFF47
      <<< wr8 0xE4 0xFF48
      <<< wr8 0xC4 0xFF49
      <<< wr8 0xFF 0xFF4C
      <<< wr8 0x7E 0xFF4D
      <<< wr8 0xFF 0xFF4E
      <<< wr8 0xFE 0xFF4F
      <<< wr8 0xFF 0xFF50
      <<< wr8 0xFF 0xFF55
      <<< wr8 0xC0 0xFF68
      <<< wr8 0xC1 0xFF6A
      <<< wr8 0xF8 0xFF70

      <<< wr8 0x3E 0xFFB6
      <<< wr8 0xC0 0xFFB7
      <<< wr8 0xE0 0xFFB8
      <<< wr8 0x46 0xFFB9
      <<< wr8 0x3E 0xFFBA
      <<< wr8 0x28 0xFFBB
      <<< wr8 0x3D 0xFFBC
      <<< wr8 0x20 0xFFBD
      <<< wr8 0xFD 0xFFBE
      <<< wr8 0xC9 0xFFBF
      <<< wr8 0x37 0xFFC0
      <<< wr8 0x1C 0xFFC1
      <<< wr8 0x24 0xFFE1
      <<< wr8 0x09 0xFFFF


Export symlinkTypeToNode

Export symlinkTypeToNode

module Node.FS
  ( FS()
  , FileDescriptor(..)
  , FileFlags(..)
  , FileMode(..)
  , SymlinkType(..)
  , symlinkTypeToNode
  , BufferLength(..)
  , BufferOffset(..)
  , ByteCount(..)
  , FilePosition(..)
  , fileFlagsToNode
  ) where

import Prelude

-- |
-- Effect type for file system usage.
--
foreign import data FS :: !

foreign import data FileDescriptor :: *

data FileFlags = R | R_PLUS | RS | RS_PLUS
               | W | WX | W_PLUS | WX_PLUS
               | A | AX | A_PLUS | AX_PLUS

fileFlagsToNode :: FileFlags -> String
fileFlagsToNode ff = case ff of
  R       -> "r"
  R_PLUS  -> "r+"
  RS      -> "rs"
  RS_PLUS -> "rs+"
  W       -> "w"
  WX      -> "wx"
  W_PLUS  -> "w+"
  WX_PLUS -> "wx+"
  A       -> "a"
  AX      -> "ax"
  A_PLUS  -> "a+"
  AX_PLUS -> "ax+"

type FileMode = Int
type FilePosition = Int
type BufferLength = Int
type BufferOffset = Int
type ByteCount = Int

-- |
-- Symlink varieties.
--
data SymlinkType = FileLink | DirLink | JunctionLink

-- |
-- Convert a `SymlinkType` to a `String` expected by the Node.js filesystem
-- API.
--
symlinkTypeToNode :: SymlinkType -> String
symlinkTypeToNode ty = case ty of
  FileLink -> "file"
  DirLink -> "dir"
  JunctionLink -> "junction"

instance showSymlinkType :: Show SymlinkType where
  show FileLink     = "FileLink"
  show DirLink      = "DirLink"
  show JunctionLink = "JunctionLink"

instance eqSymlinkType :: Eq SymlinkType where
  eq FileLink     FileLink     = true
  eq DirLink      DirLink      = true
  eq JunctionLink JunctionLink = true
  eq _ _ = false

module Node.FS
  ( FS()
  , FileDescriptor(..)
  , FileFlags(..)
  , FileMode(..)
  , SymlinkType(..)
  , BufferLength(..)
  , BufferOffset(..)
  , ByteCount(..)
  , FilePosition(..)
  , fileFlagsToNode
  ) where

import Prelude

-- |
-- Effect type for file system usage.
--
foreign import data FS :: !

foreign import data FileDescriptor :: *

data FileFlags = R | R_PLUS | RS | RS_PLUS
               | W | WX | W_PLUS | WX_PLUS
               | A | AX | A_PLUS | AX_PLUS

fileFlagsToNode :: FileFlags -> String
fileFlagsToNode ff = case ff of
  R       -> "r"
  R_PLUS  -> "r+"
  RS      -> "rs"
  RS_PLUS -> "rs+"
  W       -> "w"
  WX      -> "wx"
  W_PLUS  -> "w+"
  WX_PLUS -> "wx+"
  A       -> "a"
  AX      -> "ax"
  A_PLUS  -> "a+"
  AX_PLUS -> "ax+"

type FileMode = Int
type FilePosition = Int
type BufferLength = Int
type BufferOffset = Int
type ByteCount = Int

-- |
-- Symlink varieties.
--
data SymlinkType = FileLink | DirLink | JunctionLink

-- |
-- Convert a `SymlinkType` to a `String` expected by the Node.js filesystem
-- API.
--
symlinkTypeToNode :: SymlinkType -> String
symlinkTypeToNode ty = case ty of
  FileLink -> "file"
  DirLink -> "dir"
  JunctionLink -> "junction"

instance showSymlinkType :: Show SymlinkType where
  show FileLink     = "FileLink"
  show DirLink      = "DirLink"
  show JunctionLink = "JunctionLink"

instance eqSymlinkType :: Eq SymlinkType where
  eq FileLink     FileLink     = true
  eq DirLink      DirLink      = true
  eq JunctionLink JunctionLink = true
  eq _ _ = false


Fix partially exported class

Fix partially exported class

module Node.Yargs.Applicative
  ( Y()
  , runY
  , Arg, arg
  , yarg
  , flag
  , rest
  ) where

import Data.Maybe
import Data.Foreign
import Data.Foreign.Class
import Data.Monoid
import Data.Either
import Data.Foldable (foldMap)

import Node.Yargs
import Node.Yargs.Setup

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Exception
import Control.Alt ((<|>))

newtype Y a = Y { setup :: YargsSetup
                , read  :: Foreign -> F a
                }

unY :: forall a. Y a -> { setup :: YargsSetup, read  :: Foreign -> F a }
unY (Y y) = y

instance functorY :: Functor Y where
  (<$>) f (Y o) = Y { setup: o.setup, read: \value -> f <$> o.read value }

instance applyT :: Apply Y where
  (<*>) (Y o1) (Y o2) = Y { setup: o1.setup <> o2.setup
                          , read: \value -> o1.read value <*> o2.read value
                          }

instance applicativeY :: Applicative Y where
  pure a = Y { setup: mempty, read: \_ -> pure a }

runY :: forall a eff. YargsSetup -> Y (Eff eff a) -> Eff (err :: Exception, console :: Console | eff) a
runY setup (Y y) = do
  value <- runYargs (setup <> y.setup)
  case y.read value of
    Left err -> throwException (error (show err))
    Right action -> unsafeInterleaveEff action

class Arg a where
  arg :: String -> Y a

instance argString :: Arg String where
  arg key = Y { setup: string key
              , read: readProp key
              }

instance argBoolean :: Arg Boolean where
  arg key = Y { setup: boolean key
              , read: readProp key
              }

instance argNumber :: Arg Number where
  arg key = Y { setup: mempty
              , read: readProp key
              }

readOneOrMany :: forall a. (IsForeign a) => String -> Foreign -> F [a]
readOneOrMany key value = (pure <$> readProp key value)
                                <|> readProp key value

instance argStrings :: Arg [String] where
  arg key = Y { setup: string key
              , read: readOneOrMany key
              }

instance argBooleans :: Arg [Boolean] where
  arg key = Y { setup: boolean key
              , read: readOneOrMany key
              }

instance argNumbers :: Arg [Number] where
  arg key = Y { setup: mempty
              , read: readOneOrMany key
              }

yarg :: forall a. (Arg a) => String -> [String] -> Maybe String -> Either a String -> Boolean -> Y a
yarg key aliases desc required needArg =
  let
    y = unY (arg key)
  in Y { setup: y.setup <>
                foldMap (\a -> alias    key a) aliases <>
                foldMap (\m -> demand   key m) required <>
                foldMap (\s -> describe key s) desc <>
                if needArg then requiresArg key else mempty
       , read: case required of
           Left def -> \value -> y.read value <|> pure def
           _ -> y.read
       }

flag :: forall a. String -> [String] -> Maybe String -> Y Boolean
flag key aliases desc = yarg key aliases desc (Left false) false

rest :: Y [Foreign]
rest = Y { setup: mempty
         , read: readArray
         }

module Node.Yargs.Applicative
  ( Y()
  , runY
  , Arg
  , yarg
  , flag
  , rest
  ) where

import Data.Maybe
import Data.Foreign
import Data.Foreign.Class
import Data.Monoid
import Data.Either
import Data.Foldable (foldMap)

import Node.Yargs
import Node.Yargs.Setup

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Exception
import Control.Alt ((<|>))

newtype Y a = Y { setup :: YargsSetup
                , read  :: Foreign -> F a
                }

unY :: forall a. Y a -> { setup :: YargsSetup, read  :: Foreign -> F a }
unY (Y y) = y

instance functorY :: Functor Y where
  (<$>) f (Y o) = Y { setup: o.setup, read: \value -> f <$> o.read value }

instance applyT :: Apply Y where
  (<*>) (Y o1) (Y o2) = Y { setup: o1.setup <> o2.setup
                          , read: \value -> o1.read value <*> o2.read value
                          }

instance applicativeY :: Applicative Y where
  pure a = Y { setup: mempty, read: \_ -> pure a }

runY :: forall a eff. YargsSetup -> Y (Eff eff a) -> Eff (err :: Exception, console :: Console | eff) a
runY setup (Y y) = do
  value <- runYargs (setup <> y.setup)
  case y.read value of
    Left err -> throwException (error (show err))
    Right action -> unsafeInterleaveEff action

class Arg a where
  arg :: String -> Y a

instance argString :: Arg String where
  arg key = Y { setup: string key
              , read: readProp key
              }

instance argBoolean :: Arg Boolean where
  arg key = Y { setup: boolean key
              , read: readProp key
              }

instance argNumber :: Arg Number where
  arg key = Y { setup: mempty
              , read: readProp key
              }

readOneOrMany :: forall a. (IsForeign a) => String -> Foreign -> F [a]
readOneOrMany key value = (pure <$> readProp key value)
                                <|> readProp key value

instance argStrings :: Arg [String] where
  arg key = Y { setup: string key
              , read: readOneOrMany key
              }

instance argBooleans :: Arg [Boolean] where
  arg key = Y { setup: boolean key
              , read: readOneOrMany key
              }

instance argNumbers :: Arg [Number] where
  arg key = Y { setup: mempty
              , read: readOneOrMany key
              }

yarg :: forall a. (Arg a) => String -> [String] -> Maybe String -> Either a String -> Boolean -> Y a
yarg key aliases desc required needArg =
  let
    y = unY (arg key)
  in Y { setup: y.setup <>
                foldMap (\a -> alias    key a) aliases <>
                foldMap (\m -> demand   key m) required <>
                foldMap (\s -> describe key s) desc <>
                if needArg then requiresArg key else mempty
       , read: case required of
           Left def -> \value -> y.read value <|> pure def
           _ -> y.read
       }

flag :: forall a. String -> [String] -> Maybe String -> Y Boolean
flag key aliases desc = yarg key aliases desc (Left false) false

rest :: Y [Foreign]
rest = Y { setup: mempty
         , read: readArray
         }