Limit recursion to values from `Origin.Argv`

-- | 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 (filter (snd >>> from Origin.Argv) x) > 0
             then do
                xs <- go <|> return mempty
                return $ x ++ xs
             else return x

        from o (RichValue v) = v.origin == o
        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 <- 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


before()

before()

module JQuery where

  import Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .before(...)
  foreign import before
    "function before(ob) { \
    \  return function(ob1) { \
    \    return function () { \
    \      return ob1.before(ob); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery

module JQuery where

  import Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery


better show

better show

module Model.Presentation.New (
    PresentationError,
    Presentation,
    Slide,
    size,
    slide,
    content,
    number,
    create
) where

import Prelude (($), map, (+), clamp, (-), (<<<), compose, class Eq, class Show, show, (==), (&&), (<>))
import Data.List (List(..), (:), length, (!!))
import Data.Either (Either(..))
import Data.Maybe (fromJust)
import Partial.Unsafe (unsafePartial)
import Data.NonEmpty (NonEmpty, (:|), fromNonEmpty)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)

type PresentationError = String

type Content = SlamDown

type PresentationR = {
    _index :: Int,
    _content :: NonEmpty List Content
}
newtype Presentation = Pr PresentationR
newtype Slide = Sl PresentationR

rEq :: PresentationR -> PresentationR -> Boolean
rEq a b =
    a._index == b._index &&
    a._content == b._content

rShow :: PresentationR -> String
rShow {_index, _content : (c :| cs)} = "{page: " <> show (_index + 1) <> ", content: " <> show (c :cs) <> "}"

instance eqPresentation :: Eq Presentation where
  eq (Pr a) (Pr b) = rEq a b

instance showPresentation :: Show Presentation where
  show (Pr r) = rShow r

listSize :: forall a. NonEmpty List a -> Int
listSize = fromNonEmpty $ (compose length) <<< Cons

size :: Getter Presentation Int
size = to $ get'
  where get' (Pr {_content}) = listSize _content

clampIndex :: PresentationR -> Int -> Int
clampIndex {_content} = clamp 0 ((listSize _content) - 1)

slide :: Lens' Presentation Slide
slide = lens get' set'
  where get' (Pr r) = Sl r
        set' _ (Sl r) = Pr r

listAt :: forall a. NonEmpty List a -> Int -> a
listAt (c :| cs) i = unsafePartial $ fromJust $ (c : cs) !! i

content :: Getter Slide Content
content = to get'
  where get' (Sl {_index, _content}) = listAt _content _index

number :: Lens' Slide Int
number = lens get' set'
  where get' (Sl {_index}) = _index + 1
        set' (Sl r) i = Sl (r { _index = clampIndex r (i - 1) })

create :: String -> Either PresentationError Presentation
create source = case map slides $ parseMd source of
  Left _ -> Left "parse error"
  Right Nil -> Left "no content"
  Right (s : ss) -> Right $ Pr { _index: 0, _content: s :| ss }

module Model.Presentation.New (
    PresentationError,
    Presentation,
    Slide,
    size,
    slide,
    content,
    number,
    create
) where

import Prelude (($), map, (+), clamp, (-), (<<<), compose, class Eq, class Show, show, (==), (&&), (<>))
import Data.List (List(..), (:), length, (!!))
import Data.Either (Either(..))
import Data.Maybe (fromJust)
import Partial.Unsafe (unsafePartial)
import Data.NonEmpty (NonEmpty, (:|), fromNonEmpty)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)

type PresentationError = String

type Content = SlamDown

type PresentationR = {
    _index :: Int,
    _content :: NonEmpty List Content
}
newtype Presentation = Pr PresentationR
newtype Slide = Sl PresentationR

rEq :: PresentationR -> PresentationR -> Boolean
rEq a b =
    a._index == b._index &&
    a._content == b._content

rShow :: PresentationR -> String
rShow {_index, _content} = "{page: " <> show (_index + 1) <> ", content: " <> show _content <> "}"

instance eqPresentation :: Eq Presentation where
  eq (Pr a) (Pr b) = rEq a b

instance showPresentation :: Show Presentation where
  show (Pr r) = rShow r

listSize :: forall a. NonEmpty List a -> Int
listSize = fromNonEmpty $ (compose length) <<< Cons

size :: Getter Presentation Int
size = to $ get'
  where get' (Pr {_content}) = listSize _content

clampIndex :: PresentationR -> Int -> Int
clampIndex {_content} = clamp 0 ((listSize _content) - 1)

slide :: Lens' Presentation Slide
slide = lens get' set'
  where get' (Pr r) = Sl r
        set' _ (Sl r) = Pr r

listAt :: forall a. NonEmpty List a -> Int -> a
listAt (c :| cs) i = unsafePartial $ fromJust $ (c : cs) !! i

content :: Getter Slide Content
content = to get'
  where get' (Sl {_index, _content}) = listAt _content _index

number :: Lens' Slide Int
number = lens get' set'
  where get' (Sl {_index}) = _index + 1
        set' (Sl r) i = Sl (r { _index = clampIndex r (i - 1) })

create :: String -> Either PresentationError Presentation
create source = case map slides $ parseMd source of
  Left _ -> Left "parse error"
  Right Nil -> Left "no content"
  Right (s : ss) -> Right $ Pr { _index: 0, _content: s :| ss }


Adding some handy-dandy JQueryUI functions

module JQueryUI where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(JQuery(..))

import DOM(DOM(..))

-- .accordion(config)
foreign import accordion
  """
  function accordion(config) {
    return function(ob) {
      return function() {
        return ob.accordion(config);
      };
    };
  }
  """ :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  """
  function button(ob) {
    return function() {
      return ob.button();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  """
  function buttonset(ob) {
    return function() {
      return ob.buttonset();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  """
  function change(ob) {
    return function() {
      return ob.change();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        return ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        return ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .load(f)
foreign import load
  """
  function load(f) {
    return function (ob) {
      return function () {
        return ob.load(function() { return f(jQuery(this)); });
      };
    }
  }
  """ :: forall eff. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .replaceWith(elem)
foreign import replaceWith
  """
  function replaceWith(elem) {
    return function (ob) {
      return function () {
        return ob.replaceWith(elem);
      };
    }
  }
  """ :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .siblings(filterStr)
foreign import siblings
  """
  function siblings(filterStr) {
    return function(ob) {
      return function() {
        return ob.siblings(filterStr);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  """
  function spinner(ob) {
    return function() {
      return ob.spinner();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  """
  function tabs(ob) {
    return function() {
      return ob.tabs();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  """
  function val(newVal) {
    return function(ob) {
      return function() {
        return ob.val(newVal);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr(str)
foreign import attrStr
  """
  function attrStr(str) {
    return function(ob) {
      return function () {
        return ob.attr(str);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) String

module JQueryUI where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(JQuery(..))

import DOM(DOM(..))

-- .accordion(config)
foreign import accordion
  """
  function accordion(config) {
    return function(ob) {
      return function() {
        return ob.accordion(config);
      };
    };
  }
  """ :: forall eff r. { | r } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .button()
foreign import button
  """
  function button(ob) {
    return function() {
      return ob.button();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .buttonset()
foreign import buttonset
  """
  function buttonset(ob) {
    return function() {
      return ob.buttonset();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .change()
foreign import change
  """
  function change(ob) {
    return function() {
      return ob.change();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        return ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        return ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .siblings(filterStr)
foreign import siblings
  """
  function siblings(filterStr) {
    return function(ob) {
      return function() {
        return ob.siblings(filterStr);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .spinner()
foreign import spinner
  """
  function spinner(ob) {
    return function() {
      return ob.spinner();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .tabs()
foreign import tabs
  """
  function tabs(ob) {
    return function() {
      return ob.tabs();
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .val(newVal)
foreign import val
  """
  function val(newVal) {
    return function(ob) {
      return function() {
        return ob.val(newVal);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr(str)
foreign import attrStr
  """
  function attrStr(str) {
    return function(ob) {
      return function () {
        return ob.attr(str);
      };
    };
  }
  """ :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) String


Clamp the page number to the max sensible value

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Notebook.Port (VarMapValue(), _VarMap)
import Model.Resource (Resource(), mkFile)
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import Data.Path.Pathy ((</>), parseAbsFile, rootDir, sandbox)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Data.StrMap as SM
import qualified Model.Notebook.Cell.JTableContent as JTC

import qualified Data.StrMap as SM

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ do
    numItems <- count file
    let numPages = Math.ceil (numItems / I.toNumber perPage)
        pageIndex' = I.fromNumber $ Math.min (I.toNumber pageIndex) (numPages - 1)
    json <- sample file (pageIndex' * perPage) perPage
    return { numItems: numItems, pageNumber: pageIndex' + one, json: json }
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That results.pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

-- TODO: Remove String from being our error type.
queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql varMap)
  either errorInQuery (\out -> runJTable (mkFile (Left $ rootDir </> out)) cell) do
    j <- lmap message jobj
    out' <- j .? "out"
    path <- maybe (Left "Invalid file from SlamEngine") Right $ parseAbsFile out'
    maybe (Left "Could not sandbox SlamEngine file") Right $ sandbox rootDir path
  where
  varMap :: SM.StrMap VarMapValue
  varMap = fromMaybe SM.empty $ cell ^? _input.._VarMap

  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> err])
      `andThen` \_ -> finish cell

module Controller.Notebook.Cell.JTableContent
  ( goPage
  , stepPage
  , inputPage
  , inputPageSize
  , loadPage
  , changePageSize
  , runJTable
  , queryToJTable
  ) where

import Api.Fs (delete)
import Api.Query (port, sample, count)
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (message)
import Control.Plus (empty)
import Controller.Notebook.Common (I(), run, update, finish)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (Json(), JObject(), fromArray)
import Data.Argonaut.Decode (decodeJson)
import Data.Array (head)
import Data.Bifunctor (lmap)
import Data.Date (now)
import Data.Either (Either(..), either)
import Data.Foreign.Class (readJSON)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.These (These(..), these, theseRight, thisOrBoth)
import Global (isNaN, readInt)
import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..), CellResultContent(..))
import Model.Notebook.Cell
import Model.Notebook.Port (VarMapValue(), _VarMap)
import Model.Resource (Resource(), mkFile)
import Optic.Core ((^.), (.~), (..))
import Optic.Extended (TraversalP(), (^?))

import Data.Path.Pathy ((</>), parseAbsFile, rootDir, sandbox)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Int as I
import qualified Data.StrMap as SM
import qualified Model.Notebook.Cell.JTableContent as JTC

import qualified Data.StrMap as SM

_page :: TraversalP Cell (These String I.Int)
_page = _content .. _JTableContent .. JTC._page

_perPage :: TraversalP Cell (Either (These String I.Int) I.Int)
_perPage = _content .. _JTableContent .. JTC._perPage

currentPage :: Cell -> Maybe I.Int
currentPage cell = maybe Nothing theseRight (cell ^? _page)

currentPageSize :: Cell -> Maybe I.Int
currentPageSize cell = maybe Nothing (either theseRight Just) (cell ^? _perPage)

goPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
goPage page cell go = run cell `andThen` \_ -> go (cell # _page .~ That page)

stepPage :: forall e. I.Int -> Cell -> (Cell -> I e) -> I e
stepPage delta cell = goPage (maybe one (delta +) (currentPage cell)) cell

inputPage :: forall e. Cell -> String -> I e
inputPage cell val = update cell (_page .~ thisOrBoth val (currentPage cell))

inputPageSize :: forall e. Cell -> String -> I e
inputPageSize cell val = update cell (_perPage .~ Left (thisOrBoth val $ currentPageSize cell))

loadPage :: forall e. Cell -> (Cell -> I e) -> I e
loadPage cell go = case cell ^? _content .. _JTableContent of
  Nothing -> empty
  Just table ->
    let page = these (readPageNum one) id (flip readPageNum) (table ^. JTC._page)
        perPage = either (these (readPageNum one) id (flip readPageNum)) id (table ^. JTC._perPage)
    in run cell `andThen` \_ -> go (cell # (_page .~ That page)
                                        .. (_perPage .~ Right perPage))
    where
    readPageNum :: I.Int -> String -> I.Int
    readPageNum default str =
      let num = readInt 10 str
      in if isNaN num then default else I.fromNumber num

changePageSize :: forall e. Cell -> (Cell -> I e) -> String -> I e
changePageSize cell go "Custom" = update cell (_perPage .~ Left (That $ fromMaybe Config.defaultPageSize $ currentPageSize cell))
changePageSize cell go value = case readJSON value of
  Left _ -> empty
  Right n -> run cell
    `andThen` \_ -> go (cell # (_perPage .~ Right (I.fromNumber n))
                            .. (_page .~ That one))

runJTable :: forall e. Resource -> Cell -> I e
runJTable file cell = do
  let perPage = fromMaybe Config.defaultPageSize (currentPageSize cell)
      pageNumber = fromMaybe one (currentPage cell)
      pageIndex = pageNumber - one
  results <- liftAff $ attempt $ { numItems: _, json: _ }
    <$> count file
    <*> sample file (pageIndex * perPage) perPage
  now' <- liftEff now
  return $ case results of
      Left err -> CellResult (cell ^. _cellId) now' (Left $ NEL.singleton $ message err)
      Right results -> do
        CellResult (cell ^. _cellId) now' $ Right $ JTableContent $
          JTC.JTableContent { perPage: Right perPage
                            , page: That pageNumber
                            , result: Just $ JTC.Result
                              { totalPages: I.fromNumber $ Math.ceil (results.numItems / I.toNumber perPage)
                              , values: Just $ fromArray results.json
                              }
                            }

-- TODO: Remove String from being our error type.
queryToJTable :: forall e. Cell -> String -> Resource -> Resource -> I e
queryToJTable cell sql inp out = do
  jobj <- liftAff do
    delete out
    attempt (port inp out sql varMap)
  either errorInQuery (\out -> runJTable (mkFile (Left $ rootDir </> out)) cell) do
    j <- lmap message jobj
    out' <- j .? "out"
    path <- maybe (Left "Invalid file from SlamEngine") Right $ parseAbsFile out'
    maybe (Left "Could not sandbox SlamEngine file") Right $ sandbox rootDir path
  where
  varMap :: SM.StrMap VarMapValue
  varMap = fromMaybe SM.empty $ cell ^? _input.._VarMap

  errorInQuery :: _ -> I e
  errorInQuery err =
    update cell (_failures .~ ["Error in query: " <> err])
      `andThen` \_ -> finish cell