Give up trying to recover after final edge case

Mark the parse as 'done' using the underlying state monad once
we have reached the `draw -1` case while `skipping` is `true`.
All tests pass, but some more manual testing is due to ensure this
method does not impose unexpected side effects.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  where

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

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

    where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

          -- Check if we're done trying to recover.
          -- See the `draw -1` case below (`markDone`).
          done <- isDone
          if done
            then P.fail (_.message $ unParseError e)
            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            else if n == 0 || length xs == 0
              then
                let xs' = if isFixed arg then xss else (xs <> singleton x)
                in draw xs' errs' (-1)
              else
                let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                    xs' =
                      if D.isFree arg
                        then xs <> singleton x
                        -- If a fixed, yet optional argument failed to parse, move
                        -- on without it. We cannot requeue as it would falsify
                        -- the relationship between all positionals.

                        -- XXX: Future work could include slicing off those
                        -- branches in the group that are 'free' and re-queueing
                        -- those.
                        else if D.isOptional arg -- should this be `n - 2`?
                              then xs
                              else
                                let fs = take n xss
                                    rs = drop n xss
                                in (sortBy (compare `on` isFixed') fs) <> rs
                in draw xs' errs' (n - 1)
          )

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

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

          env <- lift ask

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

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

          if isSkipping && length missing > 0
            then do
              markDone
              expected missing i
            else
              if skippable || null i
                then
                  if not isSkipping
                    then withLocalCache do
                      exhaustP toplevel true true l args
                    else pure fallbacks
                else expected args i

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

        draw _ _ _ = pure Nil

    -- Parse a single argument from argv.
    argP'
      :: ∀ r
       . Boolean       -- ^ can we skip using fallback values?
      -> Boolean       -- ^ are we currently skipping using fallback values?
      -> Int           -- ^ recursive level
      -> D.Argument    -- ^ the argument to parse
      -> Parser (List ValueMapping)
    argP' skippable isSkipping l x = do
      state :: StateObj <- lift State.get
      if state.done then pure Nil else argP x

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

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

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

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

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

        pure $ vs <> vss

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

mapWithIndex' = flip mapWithIndex

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  where

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

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

    where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

          if false -- n == 0 || length xs == 0
            -- shortcut: there's no point trying again if there's nothing left
            -- to parse.
            then
              let xs' = if isFixed arg then xss else (xs <> singleton x)
               in draw xs' errs' (-1)
            else
              let isFixed' = isFixed <<< getIndexedElem <<< unRequired
                  xs' =
                    if D.isFree arg
                      then xs <> singleton x
                      -- If a fixed, yet optional argument failed to parse, move
                      -- on without it. We cannot requeue as it would falsify
                      -- the relationship between all positionals.

                      -- XXX: Future work could include slicing off those
                      -- branches in the group that are 'free' and re-queueing
                      -- those.
                      else if D.isOptional arg
                            then xs
                            else sortBy (compare `on` isFixed') xss
               in draw xs' errs' (n - 1)
          )

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

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

          env <- lift ask

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

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

          if isSkipping && length missing > 0
            then expected missing i
            else
              if skippable || null i
                then
                  if not isSkipping
                    then withLocalCache do
                      exhaustP toplevel true true l args
                    else pure fallbacks
                else expected args i

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

        draw _ _ _ = pure Nil

    -- Parse a single argument from argv.
    argP'
      :: ∀ r
       . Boolean       -- ^ can we skip using fallback values?
      -> Boolean       -- ^ are we currently skipping using fallback values?
      -> Int           -- ^ recursive level
      -> D.Argument    -- ^ the argument to parse
      -> Parser (List ValueMapping)
    argP' skippable isSkipping l x = do
      state :: StateObj <- lift State.get
      if state.done then pure Nil else argP x

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

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

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

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

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

        pure $ vs <> vss

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

mapWithIndex' = flip mapWithIndex

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

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

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

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


Make line chart render in safari (#1395)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Setups.Semantics where

import SlamData.Prelude

import Data.Argonaut (class DecodeJson, class EncodeJson, runJsonPrim, toPrims, JsonPrim, Json, JArray, JCursor, foldJson, cursorGet, jsonEmptyObject, (~>), (:=), (.?), decodeJson)
import Data.Array as A
import Data.Enum (fromEnum, toEnum)
import Data.Int as Int
import Data.List (List(..), catMaybes)
import Data.List as L
import Data.Map (Map, keys, update, lookup, fromFoldable)
import Data.String (take)
import Data.String.Regex (Regex, regex, match)
import Data.String.Regex.Flags as RXF
import Data.Time as Dt
import Data.Date as Dd
import Data.DateTime as Ddt

import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.StrongCheck.Gen as Gen

import Utils (stringToNumber)

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time Dt.Time
  | Date Dd.Date
  | DateTime Ddt.DateTime

derive instance eqSemantics ∷ Eq Semantics
derive instance ordSemantics ∷ Ord Semantics

instance encodeJsonChartSemantics ∷ EncodeJson Semantics where
  encodeJson = case _ of
    Value n →
      "semanticsType" := "value"
      ~> "value" := n
      ~> jsonEmptyObject
    Percent p →
      "semanticsType" := "percent"
      ~> "percent" := p
      ~> jsonEmptyObject
    Money n s →
      "semanticsType" := "money"
      ~> "value" := n
      ~> "currency" := s
      ~> jsonEmptyObject
    Bool b →
      "semanticsType" := "bool"
      ~> "value" := b
      ~> jsonEmptyObject
    Category c →
      "semanticsType" := "category"
      ~> "value" := c
      ~> jsonEmptyObject
    Time (Dt.Time h m s ms) →
      "semanticsType" := "time"
      ~> "hour" := (fromEnum h)
      ~> "minute" := (fromEnum m)
      ~> "second" := (fromEnum s)
      ~> "millisecond" := (fromEnum ms)
      ~> jsonEmptyObject
    Date d →
      "semanticsType" := "date"
      ~> "year" := (fromEnum $ Dd.year d)
      ~> "month" := (fromEnum $ Dd.month d)
      ~> "day" := (fromEnum $ Dd.day d)
      ~> jsonEmptyObject
    DateTime (Ddt.DateTime d (Dt.Time h m s ms)) →
      "semanticsType" := "datetime"
      ~> "year" := (fromEnum $ Dd.year d)
      ~> "month" := (fromEnum $ Dd.month d)
      ~> "day" := (fromEnum $ Dd.day d)
      ~> "hour" := (fromEnum h)
      ~> "minute" := (fromEnum m)
      ~> "second" := (fromEnum s)
      ~> "millisecond" := (fromEnum ms)
      ~> jsonEmptyObject

instance decodeJsonChartSemantics ∷ DecodeJson Semantics where
  decodeJson = decodeJson >=> \obj → do
    semType ← obj .? "semanticsType"
    case semType of
      "value" → decodeValue obj
      "percent" → decodePercent obj
      "money" → decodeMoney obj
      "bool" → decodeBool obj
      "category" → decodeCategory obj
      "time" → decodeTime obj
      "date" → decodeDate obj
      "datetime" → decodeDatetime obj
      _ → Left "Incorrect semanticsType"
    where
    decodeBool obj = do
      v ← obj .? "value"
      pure $ Bool v

    decodeValue obj = do
      v ← obj .? "value"
      pure $ Value v

    decodePercent obj = do
      p ← obj .? "percent"
      pure $ Percent p

    decodeMoney obj = do
      v ← obj .? "value"
      c ← obj .? "currency"
      pure $ Money v c

    decodeCategory obj = do
      v ← obj .? "value"
      pure $ Category v

    decodeTime' obj = do
      hour ← obj .? "hour"
      minute ← obj .? "minute"
      second ← obj .? "second"
      millisecond ← obj .? "millisecond"
      let
        mbTime =
          Dt.Time
          <$> (toEnum hour)
          <*> (toEnum minute)
          <*> (toEnum second)
          <*> (toEnum millisecond)
      case mbTime of
        Nothing → Left "Incorrect time"
        Just t → pure t

    decodeTime obj = do
      t ← decodeTime' obj
      pure $ Time t

    decodeDate' obj = do
      day ← obj .? "day"
      month ← obj .? "month"
      year ← obj .? "year"
      let
        mbDate = do
          y ← toEnum year
          m ← toEnum month
          d ← toEnum day
          Dd.exactDate y m d
      case mbDate of
        Nothing → Left "Incorrect date"
        Just d → pure d

    decodeDate obj = do
      d ← decodeDate' obj
      pure $ Date d

    decodeDatetime obj = do
      t ← decodeTime' obj
      d ← decodeDate' obj
      pure $ DateTime $ Ddt.DateTime d t

instance arbitraryChartSemantics ∷ Arbitrary Semantics where
  arbitrary = do
    ix ← Gen.chooseInt 0 7
    case ix of
      0 → do
        v ← arbitrary
        pure $ Value v
      1 → do
        v ← arbitrary
        pure $ Percent v
      2 → do
        v ← arbitrary
        c ← arbitrary
        pure $ Money v c
      3 → do
        v ← arbitrary
        pure $ Bool v
      4 → do
        v ← arbitrary
        pure $ Category v
      5 → do
        t ← genTime
        pure $ Time t
      6 → do
        d ← genDate
        pure $ Date d
      7 → do
        t ← genTime
        d ← genDate
        pure $ DateTime $ Ddt.DateTime d t
      _ → pure $ Value 0.0
    where
    genTime = do
      hour ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 23
      minute ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 59
      second ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 59
      millisecond ← map (fromMaybe bottom ∘ toEnum)
                    $Gen.chooseInt 0 999
      pure $ Dt.Time hour minute second millisecond
    genDate = do
      day ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 31
      month ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 12
      year ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 9999
      pure $ Dd.canonicalDate day month year

printTime ∷ Dt.Time → String
printTime time =
  let
    hour = fromEnum $ Dt.hour time
    minute = fromEnum $ Dt.minute time
    second = fromEnum $ Dt.second time
    millisecond = fromEnum $ Dt.millisecond time
    show' n = (if n > 9 then "" else "0") ⊕ show n
  in
    show' hour ⊕ ":" ⊕ show' minute ⊕ ":" ⊕ show' second ⊕ "." ⊕ show millisecond
-- We _can_ user purescript-formatters here, but printing semantics is used
-- heavily in axis analysis, so, simple printing used here instead of Μ stuff
printDate ∷ Dd.Date → String
printDate date =
  let
    year = fromEnum $ Dd.year date
    month = fromEnum $ Dd.month date
    day = fromEnum $ Dd.day date
    show' n = (if n > 9 then "" else "0") ⊕ show n
  in
    show year ⊕ "-" ⊕ show' month ⊕ "-" ⊕ show' day

printSemantics ∷ Semantics → String
printSemantics (Value v) = show v
printSemantics (Percent v) = show v <> "%"
printSemantics (Money v m) = show v <> m
printSemantics (Category s) = s
printSemantics (Bool b) = show b
printSemantics (Time t) = printTime t
printSemantics (Date d) = printDate d
printSemantics (DateTime (Ddt.DateTime d t)) = printDate d ⊕ "T" ⊕ printTime t

semanticsToSQLStrings ∷ Semantics → Array String
semanticsToSQLStrings (Value v) = [ show v ]
semanticsToSQLStrings (Percent v) = [ "\"" <> show v <> "%\"", show (v/100.0) ]
semanticsToSQLStrings (Money v m) = [ "\"" <> show v <> show m <> "\"" ]
semanticsToSQLStrings (Category s) = [ show s ]
semanticsToSQLStrings (Bool b) = [ show b ]
semanticsToSQLStrings (Time t) = [ show $ printTime t ]
semanticsToSQLStrings (Date d) = [ show $ printDate d ]
semanticsToSQLStrings (DateTime (Ddt.DateTime d t)) = [ show $ printDate d <> " " <> printTime t ]

semanticsToNumber ∷ Semantics → Maybe Number
semanticsToNumber (Value v) = pure v
semanticsToNumber (Money v _) = pure v
semanticsToNumber (Percent v) = pure v
semanticsToNumber (Bool b) = pure if b then one else zero
semanticsToNumber _ = Nothing

semanticsToTime ∷ Semantics → Maybe Dt.Time
semanticsToTime (Time t) = pure t
semanticsToTime _ = Nothing

semanticsToDate ∷ Semantics → Maybe Dd.Date
semanticsToDate (Date d) = pure d
semanticsToDate _ = Nothing

semanticsToDateTime ∷ Semantics → Maybe Ddt.DateTime
semanticsToDateTime (DateTime dt) = pure dt
semanticsToDateTime _ = Nothing

isUsedAsNothing ∷ Semantics → Boolean
isUsedAsNothing (Category "undefined") = true
isUsedAsNothing (Category "null") = true
isUsedAsNothing (Category "NA") = true
isUsedAsNothing (Category "N/A") = true
isUsedAsNothing (Category "") = true
isUsedAsNothing _ = false

analyze ∷ JsonPrim → Maybe Semantics
analyze p =
  runJsonPrim p
    (const Nothing)
    (Just ∘ Bool)
    (Just ∘ Value)
    analyzeString

analyzeJson ∷ Json → Maybe Semantics
analyzeJson =
  foldJson
    (const Nothing)
    (pure ∘ Bool)
    (pure ∘ Value)
    analyzeString
    (const Nothing)
    (const Nothing)

analyzeString ∷ String → Maybe Semantics
analyzeString str =
  analyzeTime str
  <|> analyzeDatetime str
  <|> analyzeDate str
  <|> analyzeNumber str
  <|> analyzeMoney str
  <|> analyzePercent str
  <|> (Just $ Category str)

analyzeNumber ∷ String → Maybe Semantics
analyzeNumber s = do
  num ← stringToNumber s
  guard $ show num == s || show (Int.floor num) == s
  pure $ Value num

percentRegex ∷ Regex
percentRegex = unsafePartial fromRight $ regex """^(-?\d+(\.\d+)?)\%$""" RXF.noFlags

analyzePercent ∷ String → Maybe Semantics
analyzePercent input = do
  matches ← match percentRegex input
  maybeMatch ← matches A.!! 1
  num ← maybeMatch >>= stringToNumber
  pure $ Percent num

moneyRegex ∷ Regex
moneyRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""
  curSymbols ∷ String
  curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney ∷ String → Maybe Semantics
analyzeMoney str = do
  matches ← match moneyRegex str
  maybeMatch ← matches A.!! 1
  num ← maybeMatch >>= stringToNumber
  currencySymbol ←
    let fstSymbol = take 1 str
    in if fstSymbol == ""
       then Nothing
       else pure fstSymbol
  pure $ Money num currencySymbol

datetimeRegex ∷ Regex
datetimeRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0?[1-9])-(3[0-1]|0?[1-9]|[1-2][0-9])(T| )(2[0-3]|[0-1]?[0-9]):([0-5]?[0-9]):([0-5]?[0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1]?[0-9]):[0-5]?[0-9])?$"

timeRegex ∷ Regex
timeRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(2[0-3]|[0-1][0-9]):([0-5]?[0-9]):([0-5]?[0-9])?(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1]?[0-9]):[0-5]?[0-9])?$"

dateRegex ∷ Regex
dateRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0?[1-9])-(3[0-1]|0?[1-9]|[1-2][0-9])$"

analyzeDate ∷ String → Maybe Semantics
analyzeDate str = do
  matches ← match dateRegex str
  year ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  month ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  day ← (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
  date ← Dd.exactDate year month day
  pure $ Date date

analyzeTime ∷ String → Maybe Semantics
analyzeTime str = do
  matches ← match timeRegex str
  hour ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  minute ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  let
    second = fromMaybe bottom $ (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
    millisecond = fromMaybe bottom $ (join $ matches A.!! 4) >>= Int.fromString >>= toEnum
  pure $ Time $ Dt.Time hour minute second millisecond

analyzeDatetime ∷ String → Maybe Semantics
analyzeDatetime str = do
  matches ← match datetimeRegex str
  year ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  month ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  day ← (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
  hour ← (join $ matches A.!! 5) >>= Int.fromString >>= toEnum
  minute ← (join $ matches A.!! 6) >>= Int.fromString >>= toEnum
  let
    second = fromMaybe bottom $ (join $ matches A.!! 7) >>= Int.fromString >>= toEnum
    millisecond = fromMaybe bottom $  (join $ matches A.!! 8) >>= Int.fromString >>= toEnum
    time = Dt.Time hour minute second millisecond

  date ← Dd.exactDate year month day
  pure
    $ DateTime
    $ Ddt.DateTime date time

jsonToSemantics ∷ Json → Map JCursor Semantics
jsonToSemantics j =
  fromFoldable $ catMaybes $ map (traverse analyze) $ toPrims j

jarrayToSemantics ∷ JArray → Map JCursor (List (Maybe Semantics))
jarrayToSemantics arr = foldl foldFn initial mapArr
  where
  mapArr ∷ Array (Map JCursor Semantics)
  mapArr = map jsonToSemantics arr

  initial ∷ Map JCursor (List (Maybe Semantics))
  initial = fromFoldable $ map (flip Tuple Nil) ks

  ks ∷ List JCursor
  ks = L.nub $ foldMap keys mapArr

  foldFn
    ∷ Map JCursor (List (Maybe Semantics))
    → Map JCursor Semantics
    → Map JCursor (List (Maybe Semantics))
  foldFn acc m = foldl (insertOne m) acc ks

  insertOne
    ∷ Map JCursor Semantics
    → Map JCursor (List (Maybe Semantics))
    → JCursor
    → Map JCursor (List (Maybe Semantics))
  insertOne m acc k = update (pure ∘ Cons (lookup k m)) k acc

getMaybeString ∷ Json → JCursor → Maybe String
getMaybeString js cursor =
  map printSemantics
    $ analyzeJson
    =<< cursorGet cursor js

getValues ∷ Json → Maybe JCursor → Array Number
getValues js cursor =
  foldMap A.singleton
    $ semanticsToNumber
    =<< analyzeJson
    =<< flip cursorGet js
    =<< cursor

getSemantics ∷ Json → JCursor → Maybe Semantics
getSemantics js cursor =
  cursorGet cursor js >>= analyzeJson

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Setups.Semantics where

import SlamData.Prelude

import Data.Argonaut (class DecodeJson, class EncodeJson, runJsonPrim, toPrims, JsonPrim, Json, JArray, JCursor, foldJson, cursorGet, jsonEmptyObject, (~>), (:=), (.?), decodeJson)
import Data.Array as A
import Data.Enum (fromEnum, toEnum)
import Data.Int as Int
import Data.List (List(..), catMaybes)
import Data.List as L
import Data.Map (Map, keys, update, lookup, fromFoldable)
import Data.String (take)
import Data.String.Regex (Regex, regex, match)
import Data.String.Regex.Flags as RXF
import Data.Time as Dt
import Data.Date as Dd
import Data.DateTime as Ddt

import Test.StrongCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.StrongCheck.Gen as Gen

import Utils (stringToNumber)

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time Dt.Time
  | Date Dd.Date
  | DateTime Ddt.DateTime

derive instance eqSemantics ∷ Eq Semantics
derive instance ordSemantics ∷ Ord Semantics

instance encodeJsonChartSemantics ∷ EncodeJson Semantics where
  encodeJson = case _ of
    Value n →
      "semanticsType" := "value"
      ~> "value" := n
      ~> jsonEmptyObject
    Percent p →
      "semanticsType" := "percent"
      ~> "percent" := p
      ~> jsonEmptyObject
    Money n s →
      "semanticsType" := "money"
      ~> "value" := n
      ~> "currency" := s
      ~> jsonEmptyObject
    Bool b →
      "semanticsType" := "bool"
      ~> "value" := b
      ~> jsonEmptyObject
    Category c →
      "semanticsType" := "category"
      ~> "value" := c
      ~> jsonEmptyObject
    Time (Dt.Time h m s ms) →
      "semanticsType" := "time"
      ~> "hour" := (fromEnum h)
      ~> "minute" := (fromEnum m)
      ~> "second" := (fromEnum s)
      ~> "millisecond" := (fromEnum ms)
      ~> jsonEmptyObject
    Date d →
      "semanticsType" := "date"
      ~> "year" := (fromEnum $ Dd.year d)
      ~> "month" := (fromEnum $ Dd.month d)
      ~> "day" := (fromEnum $ Dd.day d)
      ~> jsonEmptyObject
    DateTime (Ddt.DateTime d (Dt.Time h m s ms)) →
      "semanticsType" := "datetime"
      ~> "year" := (fromEnum $ Dd.year d)
      ~> "month" := (fromEnum $ Dd.month d)
      ~> "day" := (fromEnum $ Dd.day d)
      ~> "hour" := (fromEnum h)
      ~> "minute" := (fromEnum m)
      ~> "second" := (fromEnum s)
      ~> "millisecond" := (fromEnum ms)
      ~> jsonEmptyObject

instance decodeJsonChartSemantics ∷ DecodeJson Semantics where
  decodeJson = decodeJson >=> \obj → do
    semType ← obj .? "semanticsType"
    case semType of
      "value" → decodeValue obj
      "percent" → decodePercent obj
      "money" → decodeMoney obj
      "bool" → decodeBool obj
      "category" → decodeCategory obj
      "time" → decodeTime obj
      "date" → decodeDate obj
      "datetime" → decodeDatetime obj
      _ → Left "Incorrect semanticsType"
    where
    decodeBool obj = do
      v ← obj .? "value"
      pure $ Bool v

    decodeValue obj = do
      v ← obj .? "value"
      pure $ Value v

    decodePercent obj = do
      p ← obj .? "percent"
      pure $ Percent p

    decodeMoney obj = do
      v ← obj .? "value"
      c ← obj .? "currency"
      pure $ Money v c

    decodeCategory obj = do
      v ← obj .? "value"
      pure $ Category v

    decodeTime' obj = do
      hour ← obj .? "hour"
      minute ← obj .? "minute"
      second ← obj .? "second"
      millisecond ← obj .? "millisecond"
      let
        mbTime =
          Dt.Time
          <$> (toEnum hour)
          <*> (toEnum minute)
          <*> (toEnum second)
          <*> (toEnum millisecond)
      case mbTime of
        Nothing → Left "Incorrect time"
        Just t → pure t

    decodeTime obj = do
      t ← decodeTime' obj
      pure $ Time t

    decodeDate' obj = do
      day ← obj .? "day"
      month ← obj .? "month"
      year ← obj .? "year"
      let
        mbDate = do
          y ← toEnum year
          m ← toEnum month
          d ← toEnum day
          Dd.exactDate y m d
      case mbDate of
        Nothing → Left "Incorrect date"
        Just d → pure d

    decodeDate obj = do
      d ← decodeDate' obj
      pure $ Date d

    decodeDatetime obj = do
      t ← decodeTime' obj
      d ← decodeDate' obj
      pure $ DateTime $ Ddt.DateTime d t

instance arbitraryChartSemantics ∷ Arbitrary Semantics where
  arbitrary = do
    ix ← Gen.chooseInt 0 7
    case ix of
      0 → do
        v ← arbitrary
        pure $ Value v
      1 → do
        v ← arbitrary
        pure $ Percent v
      2 → do
        v ← arbitrary
        c ← arbitrary
        pure $ Money v c
      3 → do
        v ← arbitrary
        pure $ Bool v
      4 → do
        v ← arbitrary
        pure $ Category v
      5 → do
        t ← genTime
        pure $ Time t
      6 → do
        d ← genDate
        pure $ Date d
      7 → do
        t ← genTime
        d ← genDate
        pure $ DateTime $ Ddt.DateTime d t
      _ → pure $ Value 0.0
    where
    genTime = do
      hour ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 23
      minute ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 59
      second ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 59
      millisecond ← map (fromMaybe bottom ∘ toEnum)
                    $Gen.chooseInt 0 999
      pure $ Dt.Time hour minute second millisecond
    genDate = do
      day ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 31
      month ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 12
      year ← map (fromMaybe bottom ∘ toEnum) $ Gen.chooseInt 0 9999
      pure $ Dd.canonicalDate day month year

printTime ∷ Dt.Time → String
printTime time =
  let
    hour = fromEnum $ Dt.hour time
    minute = fromEnum $ Dt.minute time
    second = fromEnum $ Dt.second time
    millisecond = fromEnum $ Dt.millisecond time
    show' n = (if n > 9 then "" else "0") ⊕ show n
  in
    show' hour ⊕ ":" ⊕ show' minute ⊕ ":" ⊕ show' second ⊕ "." ⊕ show millisecond
-- We _can_ user purescript-formatters here, but printing semantics is used
-- heavily in axis analysis, so, simple printing used here instead of Μ stuff
printDate ∷ Dd.Date → String
printDate date =
  let
    year = fromEnum $ Dd.year date
    month = fromEnum $ Dd.month date
    day = fromEnum $ Dd.day date
    show' n = (if n > 9 then "" else "0") ⊕ show n
  in
    show year ⊕ "-" ⊕ show' month ⊕ "-" ⊕ show' day

printSemantics ∷ Semantics → String
printSemantics (Value v) = show v
printSemantics (Percent v) = show v <> "%"
printSemantics (Money v m) = show v <> m
printSemantics (Category s) = s
printSemantics (Bool b) = show b
printSemantics (Time t) = printTime t
printSemantics (Date d) = printDate d
printSemantics (DateTime (Ddt.DateTime d t)) = printDate d ⊕ " " ⊕ printTime t

semanticsToSQLStrings ∷ Semantics → Array String
semanticsToSQLStrings (Value v) = [ show v ]
semanticsToSQLStrings (Percent v) = [ "\"" <> show v <> "%\"", show (v/100.0) ]
semanticsToSQLStrings (Money v m) = [ "\"" <> show v <> show m <> "\"" ]
semanticsToSQLStrings (Category s) = [ show s ]
semanticsToSQLStrings (Bool b) = [ show b ]
semanticsToSQLStrings (Time t) = [ show $ printTime t ]
semanticsToSQLStrings (Date d) = [ show $ printDate d ]
semanticsToSQLStrings (DateTime (Ddt.DateTime d t)) = [ show $ printDate d <> " " <> printTime t ]

semanticsToNumber ∷ Semantics → Maybe Number
semanticsToNumber (Value v) = pure v
semanticsToNumber (Money v _) = pure v
semanticsToNumber (Percent v) = pure v
semanticsToNumber (Bool b) = pure if b then one else zero
semanticsToNumber _ = Nothing

semanticsToTime ∷ Semantics → Maybe Dt.Time
semanticsToTime (Time t) = pure t
semanticsToTime _ = Nothing

semanticsToDate ∷ Semantics → Maybe Dd.Date
semanticsToDate (Date d) = pure d
semanticsToDate _ = Nothing

semanticsToDateTime ∷ Semantics → Maybe Ddt.DateTime
semanticsToDateTime (DateTime dt) = pure dt
semanticsToDateTime _ = Nothing

isUsedAsNothing ∷ Semantics → Boolean
isUsedAsNothing (Category "undefined") = true
isUsedAsNothing (Category "null") = true
isUsedAsNothing (Category "NA") = true
isUsedAsNothing (Category "N/A") = true
isUsedAsNothing (Category "") = true
isUsedAsNothing _ = false

analyze ∷ JsonPrim → Maybe Semantics
analyze p =
  runJsonPrim p
    (const Nothing)
    (Just ∘ Bool)
    (Just ∘ Value)
    analyzeString

analyzeJson ∷ Json → Maybe Semantics
analyzeJson =
  foldJson
    (const Nothing)
    (pure ∘ Bool)
    (pure ∘ Value)
    analyzeString
    (const Nothing)
    (const Nothing)

analyzeString ∷ String → Maybe Semantics
analyzeString str =
  analyzeTime str
  <|> analyzeDatetime str
  <|> analyzeDate str
  <|> analyzeNumber str
  <|> analyzeMoney str
  <|> analyzePercent str
  <|> (Just $ Category str)

analyzeNumber ∷ String → Maybe Semantics
analyzeNumber s = do
  num ← stringToNumber s
  guard $ show num == s || show (Int.floor num) == s
  pure $ Value num

percentRegex ∷ Regex
percentRegex = unsafePartial fromRight $ regex """^(-?\d+(\.\d+)?)\%$""" RXF.noFlags

analyzePercent ∷ String → Maybe Semantics
analyzePercent input = do
  matches ← match percentRegex input
  maybeMatch ← matches A.!! 1
  num ← maybeMatch >>= stringToNumber
  pure $ Percent num

moneyRegex ∷ Regex
moneyRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""
  curSymbols ∷ String
  curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney ∷ String → Maybe Semantics
analyzeMoney str = do
  matches ← match moneyRegex str
  maybeMatch ← matches A.!! 1
  num ← maybeMatch >>= stringToNumber
  currencySymbol ←
    let fstSymbol = take 1 str
    in if fstSymbol == ""
       then Nothing
       else pure fstSymbol
  pure $ Money num currencySymbol

datetimeRegex ∷ Regex
datetimeRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0?[1-9])-(3[0-1]|0?[1-9]|[1-2][0-9])(T| )(2[0-3]|[0-1]?[0-9]):([0-5]?[0-9]):([0-5]?[0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1]?[0-9]):[0-5]?[0-9])?$"

timeRegex ∷ Regex
timeRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(2[0-3]|[0-1][0-9]):([0-5]?[0-9]):([0-5]?[0-9])?(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1]?[0-9]):[0-5]?[0-9])?$"

dateRegex ∷ Regex
dateRegex = unsafePartial fromRight $ regex rgxStr RXF.noFlags
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0?[1-9])-(3[0-1]|0?[1-9]|[1-2][0-9])$"

analyzeDate ∷ String → Maybe Semantics
analyzeDate str = do
  matches ← match dateRegex str
  year ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  month ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  day ← (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
  date ← Dd.exactDate year month day
  pure $ Date date

analyzeTime ∷ String → Maybe Semantics
analyzeTime str = do
  matches ← match timeRegex str
  hour ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  minute ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  let
    second = fromMaybe bottom $ (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
    millisecond = fromMaybe bottom $ (join $ matches A.!! 4) >>= Int.fromString >>= toEnum
  pure $ Time $ Dt.Time hour minute second millisecond

analyzeDatetime ∷ String → Maybe Semantics
analyzeDatetime str = do
  matches ← match datetimeRegex str
  year ← (join $ matches A.!! 1) >>= Int.fromString >>= toEnum
  month ← (join $ matches A.!! 2) >>= Int.fromString >>= toEnum
  day ← (join $ matches A.!! 3) >>= Int.fromString >>= toEnum
  hour ← (join $ matches A.!! 5) >>= Int.fromString >>= toEnum
  minute ← (join $ matches A.!! 6) >>= Int.fromString >>= toEnum
  let
    second = fromMaybe bottom $ (join $ matches A.!! 7) >>= Int.fromString >>= toEnum
    millisecond = fromMaybe bottom $  (join $ matches A.!! 8) >>= Int.fromString >>= toEnum
    time = Dt.Time hour minute second millisecond

  date ← Dd.exactDate year month day
  pure
    $ DateTime
    $ Ddt.DateTime date time

jsonToSemantics ∷ Json → Map JCursor Semantics
jsonToSemantics j =
  fromFoldable $ catMaybes $ map (traverse analyze) $ toPrims j

jarrayToSemantics ∷ JArray → Map JCursor (List (Maybe Semantics))
jarrayToSemantics arr = foldl foldFn initial mapArr
  where
  mapArr ∷ Array (Map JCursor Semantics)
  mapArr = map jsonToSemantics arr

  initial ∷ Map JCursor (List (Maybe Semantics))
  initial = fromFoldable $ map (flip Tuple Nil) ks

  ks ∷ List JCursor
  ks = L.nub $ foldMap keys mapArr

  foldFn
    ∷ Map JCursor (List (Maybe Semantics))
    → Map JCursor Semantics
    → Map JCursor (List (Maybe Semantics))
  foldFn acc m = foldl (insertOne m) acc ks

  insertOne
    ∷ Map JCursor Semantics
    → Map JCursor (List (Maybe Semantics))
    → JCursor
    → Map JCursor (List (Maybe Semantics))
  insertOne m acc k = update (pure ∘ Cons (lookup k m)) k acc

getMaybeString ∷ Json → JCursor → Maybe String
getMaybeString js cursor =
  map printSemantics
    $ analyzeJson
    =<< cursorGet cursor js

getValues ∷ Json → Maybe JCursor → Array Number
getValues js cursor =
  foldMap A.singleton
    $ semanticsToNumber
    =<< analyzeJson
    =<< flip cursorGet js
    =<< cursor

getSemantics ∷ Json → JCursor → Maybe Semantics
getSemantics js cursor =
  cursorGet cursor js >>= analyzeJson


Fix smart constructor example.

Fix smart constructor example.

module Data.DOM.Smart
  ( Element()
  , Attribute()
  , Content()
  , AttributeKey()

  , a
  , div
  , p
  , img

  , href
  , _class
  , src
  , width
  , height

  , (:=)
  , text
  , elem

  , render
  ) where

import Data.Maybe
import Data.Array (map)
import Data.String (joinWith)

newtype Element = Element
  { name         :: String
  , attribs      :: [Attribute]
  , content      :: Maybe [Content]
  }

data Content
  = TextContent String
  | ElementContent Element

newtype Attribute = Attribute
  { key          :: String
  , value        :: String
  }

element :: String -> [Attribute] -> Maybe [Content] -> Element
element name attribs content = Element
  { name:      name
  , attribs:   attribs
  , content:   content
  }

text :: String -> Content
text = TextContent

elem :: Element -> Content
elem = ElementContent

newtype AttributeKey = AttributeKey String

(:=) :: AttributeKey -> String -> Attribute
(:=) (AttributeKey key) value = Attribute
  { key: key
  , value: value
  }

a :: [Attribute] -> [Content] -> Element
a attribs content = element "a" attribs (Just content)

div :: [Attribute] -> [Content] -> Element
div attribs content = element "div" attribs (Just content)

p :: [Attribute] -> [Content] -> Element
p attribs content = element "p" attribs (Just content)

img :: [Attribute] -> Element
img attribs = element "img" attribs Nothing

href :: AttributeKey
href = AttributeKey "href"

_class :: AttributeKey
_class = AttributeKey "class"

src :: AttributeKey
src = AttributeKey "src"

width :: AttributeKey
width = AttributeKey "width"

height :: AttributeKey
height = AttributeKey "height"

render :: Element -> String
render (Element e) =
  "<" ++ e.name ++
  " " ++ joinWith " " (map renderAttribute e.attribs) ++
  renderContent e.content

  where
  renderAttribute :: Attribute -> String
  renderAttribute (Attribute a) = a.key ++ "=\"" ++ a.value ++ "\""

  renderContent :: Maybe [Content] -> String
  renderContent Nothing = " />"
  renderContent (Just content) =
    ">" ++ joinWith "" (map renderContentItem content) ++
    "</" ++ e.name ++ ">"
    where
    renderContentItem :: Content -> String
    renderContentItem (TextContent s) = s
    renderContentItem (ElementContent e) = render e

module Data.DOM.Smart
  ( Element()
  , Attribute()
  , Content()
  , AttributeKey()

  , a
  , div
  , p
  , img

  , href
  , _class
  , src
  , width
  , height

  , (:=)
  , text
  , elem

  , render
  ) where

import Data.Maybe
import Data.Array (map)
import Data.String (joinWith)

newtype Element = Element
  { name         :: String
  , attribs      :: [Attribute]
  , content      :: Maybe [Content]
  }

data Content
  = TextContent String
  | ElementContent Element

newtype Attribute = Attribute
  { key          :: String
  , value        :: String
  }

element :: String -> [Attribute] -> Maybe [Content] -> Element
element name attribs content = Element
  { name:      name
  , attribs:   attribs
  , content:   content
  }

text :: String -> Content
text = TextContent

elem :: Element -> Content
elem = ElementContent

newtype AttributeKey = AttributeKey String

(:=) :: AttributeKey -> String -> Attribute
(:=) (AttributeKey key) value = Attribute
  { key: key
  , value: show value
  }

a :: [Attribute] -> [Content] -> Element
a attribs content = element "a" attribs (Just content)

div :: [Attribute] -> [Content] -> Element
div attribs content = element "div" attribs (Just content)

p :: [Attribute] -> [Content] -> Element
p attribs content = element "p" attribs (Just content)

img :: [Attribute] -> Element
img attribs = element "img" attribs Nothing

href :: AttributeKey
href = AttributeKey "href"

_class :: AttributeKey
_class = AttributeKey "class"

src :: AttributeKey
src = AttributeKey "src"

width :: AttributeKey
width = AttributeKey "width"

height :: AttributeKey
height = AttributeKey "height"

render :: Element -> String
render (Element e) =
  "<" ++ e.name ++
  " " ++ joinWith " " (map renderAttribute e.attribs) ++
  renderContent e.content

  where
  renderAttribute :: Attribute -> String
  renderAttribute (Attribute a) = a.key ++ "=\"" ++ a.value ++ "\""

  renderContent :: Maybe [Content] -> String
  renderContent Nothing = " />"
  renderContent (Just content) =
    ">" ++ joinWith "" (map renderContentItem content) ++
    "</" ++ e.name ++ ">"
    where
    renderContentItem :: Content -> String
    renderContentItem (TextContent s) = s
    renderContentItem (ElementContent e) = render e