Update Parser.purs

Update Parser.purs

-- | 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
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State(), runState, evalState, execState)
import Control.Monad.State as State
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O
import Language.Docopt.Value    as Value

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

-- |
-- | Unfortunately, the State Monad is needed because we try matching all
-- | program branches and must select the best fit.
-- |
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT D.Env (State Int))
                          a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- 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 D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

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

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

dash :: Parser D.Value
dash = token go P.<?> "stdin flag"
  where
    go (Lit v) | v == "-" = Just (D.BoolValue true)
    go _                  = Nothing

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

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.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) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- 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"
             Nothing -> return $ OptParse (D.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) atok | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s) Nothing false
          _      -> Left "Invalid substring"

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

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  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:    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.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (Value.read a)
                          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) && (A.length xs > 0)
      = return $ OptParse (D.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.length xs == 0)
      = case v of
              Just _  -> Left "Option takes no argument"
              Nothing -> return $ OptParse (D.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 }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", "
                  $ prettyPrintToken <<< _.token <<< unPositionedToken <$> s)

-- | 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
  _.result <<< unScoredResult
    <$> genBranchesParser (concat $ D.runUsage <$> xs)
                          true
                          optsFirst

-- | 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"
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env :: D.Env <- ask
    let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> do
                            genBranchParser x optsFirst
                            <* if term then eof else return unit
        rs = evalState (runReaderT (collect s ps) env) 0
    return $ maybe'
      (\_ ->
        maybe'
          (\_ -> P.parseFailed Nil P.initialPos
                  "The impossible happened. Failure without error")
          (\e -> e { result = Left e.result.error })
          (maximumBy (compare `on` (_.depth <<< _.result)) $ mlefts rs)
      )
      (\r -> r { result = Right r.result.value })
      (maximumBy (compare `on` (_.depth <<< _.result)) $ mrights rs)

  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o -> do
                    depth :: Int <- lift State.get
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { error: e, depth: depth }
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { value: r, depth: depth }
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- The usage branch
                -> Boolean   -- ^ Enable "options-first"
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst = do
  lift (State.put 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 xs
                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
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      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
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

        draw _ _ = return mempty

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

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

    step (Free p) x@(D.Group _ bs _) | 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
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ 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
        rss <- genParser y
        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 <$> do
                  D.StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return $ ScoredResult {
                      score: 1
                    , result: rest
                    }
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (command n)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      <* lift (State.modify (1+))
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        dash
        return (D.BoolValue true)
      <* lift (State.modify (1+))
      ) P.<?> "stdin: \"-\""

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

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
      <* lift (State.modify (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)
            if isLopt
               then P.try $ Tuple x <$> mkLoptParser o.name o.arg
               else if isSopt
                then P.try $ Tuple x <$> mkSoptParser o.flag o.arg
                else P.fail "long or short option"

          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"

    genParser x@(D.Group optional bs r)
      | optional && 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 an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then goR else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where
        goR :: Parser (List (List ValueMapping))
        goR = do
          {score, result} <- unScoredResult <$> genBranchesParser bs false false
          if score == 0
              then return $ singleton (snd result)
              else do
                xs <- goR <|> pure Nil
                return $ (snd result) : xs

        go :: Parser (List ValueMapping)
        go = if length bs == 0
                  then return mempty
                  else do
                    snd <<< _.result <<<  unScoredResult
                      <$> genBranchesParser bs false false

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false

-- | 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
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State(), runState, evalState, execState)
import Control.Monad.State as State
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O
import Language.Docopt.Value    as Value

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

-- |
-- | Unfortunately, the State Monad is needed because we try matching all
-- | program branches and must select the best fit.
-- |
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT D.Env (State Int))
                          a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- 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 D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

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

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

dash :: Parser D.Value
dash = token go P.<?> "stdin flag"
  where
    go (Lit v) | v == "-" = Just (D.BoolValue true)
    go _                  = Nothing

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

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.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) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- 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"
             Nothing -> return $ OptParse (D.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) atok | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s) Nothing false
          _      -> Left "Invalid substring"

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

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  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:    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.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (Value.read a)
                          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) && (A.length xs > 0)
      = return $ OptParse (D.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.length xs == 0)
      = case v of
              Just _  -> Left "Option takes no argument"
              Nothing -> return $ OptParse (D.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 }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", "
                  $ prettyPrintToken <<< _.token <<< unPositionedToken <$> s)

-- | 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
  _.result <<< unScoredResult
    <$> genBranchesParser (concat $ D.runUsage <$> xs)
                          true
                          optsFirst

-- | 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"
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env :: D.Env <- ask
    let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> do
                            genBranchParser x optsFirst
                            <* if term then eof else return unit
        rs = evalState (runReaderT (collect s ps) env) 0
    return $ maybe'
      (\_ ->
        maybe'
          (\_ -> P.parseFailed Nil P.initialPos
                  "The impossible happened. Failure without error")
          (\e -> e { result = Left e.result.error })
          (maximumBy (compare `on` (_.depth <<< _.result)) $ mlefts rs)
      )
      (\r -> r { result = Right r.result.value })
      (maximumBy (compare `on` (_.depth <<< _.result)) $ mrights rs)

  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o -> do
                    depth :: Int <- lift State.get
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { error: e, depth: depth }
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { value: r, depth: depth }
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- The usage branch
                -> Boolean   -- ^ Enable "options-first"
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst = do
  lift (State.put 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 xs
                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
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      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
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

        draw _ _ = return mempty

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

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

    step (Free p) x@(D.Group _ bs _) | 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
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ 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
        rss <- genParser y
        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 <$> do
                  D.StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return $ ScoredResult {
                      score: 1
                    , result: rest
                    }
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (command n)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      <* lift (State.modify (1+))
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        dash
        return (D.BoolValue true)
      <* lift (State.modify (1+))
      ) P.<?> "stdin: \"-\""

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

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
      <* lift (State.modify (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)
            if isLopt
               then P.try $ Tuple x <$> mkLoptParser o.name o.arg
               else if isSopt
                then P.try $ Tuple x <$> mkSoptParser o.flag o.arg
                else P.fail "long or short option"

          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"

    genParser x@(D.Group optional bs r)
      | optional && 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)))

      where foo = false

    -- 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) = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then goR else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where
        goR :: Parser (List (List ValueMapping))
        goR = do
          {score, result} <- unScoredResult <$> genBranchesParser bs false false
          if score == 0
              then return $ singleton (snd result)
              else do
                xs <- goR <|> pure Nil
                return $ (snd result) : xs

        go :: Parser (List ValueMapping)
        go = if length bs == 0
                  then return mempty
                  else do
                    snd <<< _.result <<<  unScoredResult
                      <$> genBranchesParser bs false false

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false


resolve ImplicitImport

resolve ImplicitImport

{-
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.Chart.ChartOptions.Common where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array (catMaybes, cons, (!!))
import Data.Array as A
import Data.Int (toNumber)
import Data.Lens (view)
import Data.List (List(..), replicate, length)
import Data.List as L
import Data.Map (Map)
import Data.Map as M

import Color (Color, toRGBA, fromHexString, hsla, toHSLA)

import ECharts (AxisRec, AxisLabel(..), TextStyle(..), textStyleDefault, axisLabelDefault)

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, JSelect)
import SlamData.Workspace.Card.Chart.Semantics (Semantics, printSemantics, semanticsToNumber)

type ChartAxises =
  { dimensions ∷ Array (List (Maybe String))
  , series ∷ Array (List (Maybe String))
  , measures ∷ Array (List (Maybe Number))
  , aggregations ∷ Array (Maybe Aggregation)
  }

colors ∷ Array String
colors =
  [ "#93A9A6"
  , "#CDA71F"
  , "#EB6F76"
  , "#66B35B"
  , "#BD97E2"
  , "#5B5925"
  , "#884A6F"
  , "#51B3F6"
  , "#CCA067"
  , "#398465"
  , "#3C607A"
  , "#81463C"
  , "#B65F33"
  , "#9AAE31"
  , "#CE8B9E"
  , "#6C6356"
  , "#95A779"
  , "#44AECB"
  , "#E987C2"
  , "#8A7EA0"
  , "#3D6C2F"
  , "#40B994"
  , "#87984A"
  , "#C1A088"
  , "#9B6E2D"
  , "#428C8D"
  , "#B8766A"
  , "#EB8666"
  , "#DF883E"
  , "#BB6273"
  , "#C994BF"
  , "#929DE0"
  , "#7BA5CB"
  , "#AE9093"
  , "#66557B"
  , "#936370"
  , "#3C6D64"
  , "#84693F"
  , "#C19744"
  , "#E77AA1"
  , "#5D555F"
  , "#4078A2"
  , "#3FAFAF"
  , "#698B99"
  , "#486A4C"
  , "#7EA48B"
  , "#B57E57"
  , "#8C72AA"
  , "#609050"
  , "#56B379"
  , "#489F8B"
  , "#714D4A"
  , "#9A8867"
  , "#93B66B"
  , "#7DA93F"
  , "#877424"
  , "#C75D56"
  , "#B774AC"
  , "#7B7A3E"
  , "#73581C"
  , "#398EA3"
  , "#964734"
  , "#DF8D89"
  , "#AF97CC"
  , "#96951F"
  , "#A37791"
  , "#7C4D2E"
  , "#78865F"
  , "#216B74"
  , "#935524"
  , "#6FAFB6"
  , "#75AB76"
  , "#A48B50"
  , "#D28DD0"
  , "#BE9AAF"
  , "#AD8D22"
  , "#D89576"
  , "#964860"
  , "#9B9A61"
  , "#4DAADB"
  , "#A9628D"
  , "#98943B"
  , "#486366"
  , "#6D7E2B"
  , "#CF9A2F"
  , "#827A8B"
  , "#876A69"
  , "#495F23"
  , "#677F45"
  , "#805845"
  , "#A2544D"
  , "#8C5157"
  , "#6B6C9E"
  , "#236443"
  , "#919B82"
  , "#CC8E55"
  , "#3E8555"
  , "#A08A7A"
  , "#767870"
  , "#6D9643"
  , "#87658F"
  , "#3BB069"
  , "#6A5D42"
  , "#586249"
  , "#1F7769"
  , "#6DAF8E"
  , "#8FA7BE"
  , "#B7A82C"
  , "#A09DA0"
  , "#7D8AA6"
  , "#78A3E0"
  , "#719186"
  , "#765771"
  , "#A37EA7"
  , "#8E8CBC"
  , "#A76840"
  , "#49934B"
  , "#A27C62"
  , "#3DA27B"
  , "#A9AC53"
  , "#6685B4"
  , "#5F728A"
  , "#CB6B4A"
  , "#9F8DD3"
  , "#B7A66E"
  , "#A998B3"
  , "#85A362"
  , "#595146"
  ]

getShadeColor ∷ String → Number → Color
getShadeColor hex alpha =
  setAlpha
    (lightenTo
      (fromMaybe
        (hsla 0.0 0.0 0.0 1.0)
        (fromHexString hex))
      0.95)
    alpha
  where
  lightenTo :: Color → Number → Color
  lightenTo col l' = hsla c.h c.s l' c.a
    where
    c = toHSLA col

  setAlpha :: Color → Number → Color
  setAlpha col a' = hsla c.h c.s c.l a'
    where
    c = toHSLA col

toRGBAString ∷ Color → String
toRGBAString col = "rgba(" <> show c.r <> ", "
                   <> show c.g <> ", "
                   <> show c.b <> ", "
                   <> show c.a <> ")"
  where c = toRGBA col

buildChartAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → ChartAxises
buildChartAxises axisMap conf =
  { dimensions: dimensions
  , series: series
  , measures: measures
  , aggregations: aggregations
  }
  where
  dimensions ∷ Array (List (Maybe String))
  dimensions = map (map (map printSemantics)) $ getAxises conf.dimensions

  series ∷ Array (List (Maybe String))
  series = map (map (map printSemantics)) $ getAxises conf.series

  measures ∷ Array (List (Maybe Number))
  measures = map (map (flip bind semanticsToNumber)) $ getAxises conf.measures

  getAxises ∷ Array JSelect → Array (List (Maybe Semantics))
  getAxises sels =
    map Ax.runAxis $ catMaybes $ map (view _value >=> flip M.lookup axisMap) sels

  aggregations ∷ Array (Maybe Aggregation)
  aggregations = map (view _value) conf.aggregations

type Key = Tuple String SeriesKey
type SeriesKey = Maybe (Tuple String (Maybe String))

keyCategory ∷ Key → String
keyCategory (Tuple cat _) = cat

keyMbSeries1 ∷ Key → Maybe String
keyMbSeries1 (Tuple _ mbT) = mbT >>= (pure ∘ fst)

keyMbSeries2 ∷ Key → Maybe String
keyMbSeries2 (Tuple _ mbT) = mbT >>= snd

mkKey ∷ String → Maybe String → Maybe String → Key
mkKey cat f s =
  Tuple cat (f >>= \f → pure $ Tuple f s)

keyName ∷ Key → String
keyName k =
  (fromMaybe "" (keyMbSeries1 k)) <> (maybe "" (":" <> _) (keyMbSeries2 k))

type LabeledPoints = M.Map Key (Array Number)
type PieBarData = M.Map Key Number

pieBarData ∷ ChartAxises → PieBarData
pieBarData axises =
  aggregate agg $ pieBarRawData categories firstSeries secondSeries values M.empty
  where
  agg ∷ Aggregation
  agg = fromMaybe Sum $ join (axises.aggregations !! 0)

  categories ∷ List (Maybe String)
  categories = fromMaybe Nil $ axises.series !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axises.measures !! 0

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 1

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 2

  nothings ∷ forall a. List (Maybe a)
  nothings = replicate (length values) Nothing

pieBarRawData
  ∷ List (Maybe String) → List (Maybe String) → List (Maybe String)
  → List (Maybe Number) → LabeledPoints → LabeledPoints
pieBarRawData Nil _ _ _ acc = acc
pieBarRawData _ Nil _ _ acc = acc
pieBarRawData _ _ Nil _ acc = acc
pieBarRawData _ _ _ Nil acc = acc
pieBarRawData (Cons Nothing _) _ _ _ acc = acc
pieBarRawData (Cons (Just category) cs) (Cons mbFirstSerie fss)
  (Cons mbSecondSerie sss) (Cons mbValue vs) acc =
  pieBarRawData cs fss sss vs $ M.alter (alterFn val) key acc
  where
  key ∷ Key
  key = mkKey category mbFirstSerie mbSecondSerie

  val ∷ Number
  val = fromMaybe zero mbValue

  alterFn ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterFn v vals = pure $ cons v $ fromMaybe [] vals

aggregate ∷ Aggregation → LabeledPoints → PieBarData
aggregate agg acc = map (runAggregation agg) acc

-- Having array of pairs Key → Number and array of categories (String)
-- 1. drop any pair theat has no category from second argument
-- 2. group by category
-- 3. apply first argument to groupped maps
-- 4. make final map from category to array of values
commonNameMap
  ∷ (Array (Map String Number) → Array (Map String Number)) → Array String
  → Array (Tuple Key Number) → Map String (Array Number)
commonNameMap fn catVals = mapByCategories ∘ fn ∘ groupByCategories
  where
  groupByCategories ∷ Array (Tuple Key Number) → Array (Map String Number)
  groupByCategories arr = map (markAndFilterCategory arr) catVals

  markAndFilterCategory
    ∷ Array (Tuple Key Number) → String → Map String Number
  markAndFilterCategory arr cat =
      M.fromList
    $ L.toList
    $ map (lmap keyName)
    $ A.filter (\(Tuple k _) → keyCategory k == cat)
    $ arr

  mapByCategories
    ∷ Array (Map String Number) → Map String (Array Number)
  mapByCategories arr =
    map A.reverse $ foldl foldFn M.empty (L.fromList ∘ M.toList <$> arr)

  foldFn
    ∷ Map String (Array Number)
    → Array (Tuple String Number)
    → Map String (Array Number)
  foldFn m tpls = foldl (\m (Tuple k n) → M.alter (alterNamed n) k m) m tpls

  alterNamed ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterNamed n ns = Just $ A.cons n $ fromMaybe [] ns

mixAxisLabelAngleAndFontSize ∷ Int → Int → AxisRec → AxisRec
mixAxisLabelAngleAndFontSize angle size r =
  r { axisLabel = Just $ AxisLabel axisLabelDefault
      { rotate = Just $ toNumber angle
      , textStyle = Just $ TextStyle textStyleDefault
        { fontSize = Just $ toNumber size
        , fontFamily = Just "Ubuntu sans"
        }
      }
    }

{-
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.Chart.ChartOptions.Common where

import SlamData.Prelude (Maybe(Just, Nothing), Tuple(Tuple), ($), (∘), fromMaybe, foldl, (<$>), map, (==), lmap, pure, zero, join, (<>), maybe, (>>=), snd, fst, flip, (>=>), bind, show)

import Data.Argonaut (JCursor)
import Data.Array (catMaybes, cons, (!!))
import Data.Array as A
import Data.Int (toNumber)
import Data.Lens (view)
import Data.List (List(..), replicate, length)
import Data.List as L
import Data.Map (Map)
import Data.Map as M

import Color (Color, toRGBA, fromHexString, hsla, toHSLA)

import ECharts (AxisRec, AxisLabel(..), TextStyle(..), textStyleDefault, axisLabelDefault)

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, JSelect)
import SlamData.Workspace.Card.Chart.Semantics (Semantics, printSemantics, semanticsToNumber)

type ChartAxises =
  { dimensions ∷ Array (List (Maybe String))
  , series ∷ Array (List (Maybe String))
  , measures ∷ Array (List (Maybe Number))
  , aggregations ∷ Array (Maybe Aggregation)
  }

colors ∷ Array String
colors =
  [ "#93A9A6"
  , "#CDA71F"
  , "#EB6F76"
  , "#66B35B"
  , "#BD97E2"
  , "#5B5925"
  , "#884A6F"
  , "#51B3F6"
  , "#CCA067"
  , "#398465"
  , "#3C607A"
  , "#81463C"
  , "#B65F33"
  , "#9AAE31"
  , "#CE8B9E"
  , "#6C6356"
  , "#95A779"
  , "#44AECB"
  , "#E987C2"
  , "#8A7EA0"
  , "#3D6C2F"
  , "#40B994"
  , "#87984A"
  , "#C1A088"
  , "#9B6E2D"
  , "#428C8D"
  , "#B8766A"
  , "#EB8666"
  , "#DF883E"
  , "#BB6273"
  , "#C994BF"
  , "#929DE0"
  , "#7BA5CB"
  , "#AE9093"
  , "#66557B"
  , "#936370"
  , "#3C6D64"
  , "#84693F"
  , "#C19744"
  , "#E77AA1"
  , "#5D555F"
  , "#4078A2"
  , "#3FAFAF"
  , "#698B99"
  , "#486A4C"
  , "#7EA48B"
  , "#B57E57"
  , "#8C72AA"
  , "#609050"
  , "#56B379"
  , "#489F8B"
  , "#714D4A"
  , "#9A8867"
  , "#93B66B"
  , "#7DA93F"
  , "#877424"
  , "#C75D56"
  , "#B774AC"
  , "#7B7A3E"
  , "#73581C"
  , "#398EA3"
  , "#964734"
  , "#DF8D89"
  , "#AF97CC"
  , "#96951F"
  , "#A37791"
  , "#7C4D2E"
  , "#78865F"
  , "#216B74"
  , "#935524"
  , "#6FAFB6"
  , "#75AB76"
  , "#A48B50"
  , "#D28DD0"
  , "#BE9AAF"
  , "#AD8D22"
  , "#D89576"
  , "#964860"
  , "#9B9A61"
  , "#4DAADB"
  , "#A9628D"
  , "#98943B"
  , "#486366"
  , "#6D7E2B"
  , "#CF9A2F"
  , "#827A8B"
  , "#876A69"
  , "#495F23"
  , "#677F45"
  , "#805845"
  , "#A2544D"
  , "#8C5157"
  , "#6B6C9E"
  , "#236443"
  , "#919B82"
  , "#CC8E55"
  , "#3E8555"
  , "#A08A7A"
  , "#767870"
  , "#6D9643"
  , "#87658F"
  , "#3BB069"
  , "#6A5D42"
  , "#586249"
  , "#1F7769"
  , "#6DAF8E"
  , "#8FA7BE"
  , "#B7A82C"
  , "#A09DA0"
  , "#7D8AA6"
  , "#78A3E0"
  , "#719186"
  , "#765771"
  , "#A37EA7"
  , "#8E8CBC"
  , "#A76840"
  , "#49934B"
  , "#A27C62"
  , "#3DA27B"
  , "#A9AC53"
  , "#6685B4"
  , "#5F728A"
  , "#CB6B4A"
  , "#9F8DD3"
  , "#B7A66E"
  , "#A998B3"
  , "#85A362"
  , "#595146"
  ]

getShadeColor ∷ String → Number → Color
getShadeColor hex alpha =
  setAlpha
    (lightenTo
      (fromMaybe
        (hsla 0.0 0.0 0.0 1.0)
        (fromHexString hex))
      0.95)
    alpha
  where
  lightenTo :: Color → Number → Color
  lightenTo col l' = hsla c.h c.s l' c.a
    where
    c = toHSLA col

  setAlpha :: Color → Number → Color
  setAlpha col a' = hsla c.h c.s c.l a'
    where
    c = toHSLA col

toRGBAString ∷ Color → String
toRGBAString col = "rgba(" <> show c.r <> ", "
                   <> show c.g <> ", "
                   <> show c.b <> ", "
                   <> show c.a <> ")"
  where c = toRGBA col

buildChartAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → ChartAxises
buildChartAxises axisMap conf =
  { dimensions: dimensions
  , series: series
  , measures: measures
  , aggregations: aggregations
  }
  where
  dimensions ∷ Array (List (Maybe String))
  dimensions = map (map (map printSemantics)) $ getAxises conf.dimensions

  series ∷ Array (List (Maybe String))
  series = map (map (map printSemantics)) $ getAxises conf.series

  measures ∷ Array (List (Maybe Number))
  measures = map (map (flip bind semanticsToNumber)) $ getAxises conf.measures

  getAxises ∷ Array JSelect → Array (List (Maybe Semantics))
  getAxises sels =
    map Ax.runAxis $ catMaybes $ map (view _value >=> flip M.lookup axisMap) sels

  aggregations ∷ Array (Maybe Aggregation)
  aggregations = map (view _value) conf.aggregations

type Key = Tuple String SeriesKey
type SeriesKey = Maybe (Tuple String (Maybe String))

keyCategory ∷ Key → String
keyCategory (Tuple cat _) = cat

keyMbSeries1 ∷ Key → Maybe String
keyMbSeries1 (Tuple _ mbT) = mbT >>= (pure ∘ fst)

keyMbSeries2 ∷ Key → Maybe String
keyMbSeries2 (Tuple _ mbT) = mbT >>= snd

mkKey ∷ String → Maybe String → Maybe String → Key
mkKey cat f s =
  Tuple cat (f >>= \f → pure $ Tuple f s)

keyName ∷ Key → String
keyName k =
  (fromMaybe "" (keyMbSeries1 k)) <> (maybe "" (":" <> _) (keyMbSeries2 k))

type LabeledPoints = M.Map Key (Array Number)
type PieBarData = M.Map Key Number

pieBarData ∷ ChartAxises → PieBarData
pieBarData axises =
  aggregate agg $ pieBarRawData categories firstSeries secondSeries values M.empty
  where
  agg ∷ Aggregation
  agg = fromMaybe Sum $ join (axises.aggregations !! 0)

  categories ∷ List (Maybe String)
  categories = fromMaybe Nil $ axises.series !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axises.measures !! 0

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 1

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 2

  nothings ∷ forall a. List (Maybe a)
  nothings = replicate (length values) Nothing

pieBarRawData
  ∷ List (Maybe String) → List (Maybe String) → List (Maybe String)
  → List (Maybe Number) → LabeledPoints → LabeledPoints
pieBarRawData Nil _ _ _ acc = acc
pieBarRawData _ Nil _ _ acc = acc
pieBarRawData _ _ Nil _ acc = acc
pieBarRawData _ _ _ Nil acc = acc
pieBarRawData (Cons Nothing _) _ _ _ acc = acc
pieBarRawData (Cons (Just category) cs) (Cons mbFirstSerie fss)
  (Cons mbSecondSerie sss) (Cons mbValue vs) acc =
  pieBarRawData cs fss sss vs $ M.alter (alterFn val) key acc
  where
  key ∷ Key
  key = mkKey category mbFirstSerie mbSecondSerie

  val ∷ Number
  val = fromMaybe zero mbValue

  alterFn ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterFn v vals = pure $ cons v $ fromMaybe [] vals

aggregate ∷ Aggregation → LabeledPoints → PieBarData
aggregate agg acc = map (runAggregation agg) acc

-- Having array of pairs Key → Number and array of categories (String)
-- 1. drop any pair theat has no category from second argument
-- 2. group by category
-- 3. apply first argument to groupped maps
-- 4. make final map from category to array of values
commonNameMap
  ∷ (Array (Map String Number) → Array (Map String Number)) → Array String
  → Array (Tuple Key Number) → Map String (Array Number)
commonNameMap fn catVals = mapByCategories ∘ fn ∘ groupByCategories
  where
  groupByCategories ∷ Array (Tuple Key Number) → Array (Map String Number)
  groupByCategories arr = map (markAndFilterCategory arr) catVals

  markAndFilterCategory
    ∷ Array (Tuple Key Number) → String → Map String Number
  markAndFilterCategory arr cat =
      M.fromList
    $ L.toList
    $ map (lmap keyName)
    $ A.filter (\(Tuple k _) → keyCategory k == cat)
    $ arr

  mapByCategories
    ∷ Array (Map String Number) → Map String (Array Number)
  mapByCategories arr =
    map A.reverse $ foldl foldFn M.empty (L.fromList ∘ M.toList <$> arr)

  foldFn
    ∷ Map String (Array Number)
    → Array (Tuple String Number)
    → Map String (Array Number)
  foldFn m tpls = foldl (\m (Tuple k n) → M.alter (alterNamed n) k m) m tpls

  alterNamed ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterNamed n ns = Just $ A.cons n $ fromMaybe [] ns

mixAxisLabelAngleAndFontSize ∷ Int → Int → AxisRec → AxisRec
mixAxisLabelAngleAndFontSize angle size r =
  r { axisLabel = Just $ AxisLabel axisLabelDefault
      { rotate = Just $ toNumber angle
      , textStyle = Just $ TextStyle textStyleDefault
        { fontSize = Just $ toNumber size
        , fontFamily = Just "Ubuntu sans"
        }
      }
    }


chart-fix

chart-fix

{-
Copyright 2015 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 Model.ChartSemantics where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff (Eff())
import Control.Monad.ST (STRef(), ST(), newSTRef, modifySTRef, readSTRef, pureST)
import Control.MonadPlus (guard)
import Data.Argonaut
  ( runJsonPrim, toPrims, JsonPrim(), Json(), JArray(), JCursor()
  , DecodeJson, EncodeJson, decodeJson, jsonEmptyObject, (:=), (.?), (~>))
import Data.Array as A
import Data.Array.ST
import Data.Either (Either(..))
import Data.Foldable (foldl, foldMap)
import Data.List (List(..), reverse, catMaybes, toList)
import Data.List as L
import Data.Map (Map(), keys, update, lookup, fromList)
import Data.Maybe (Maybe(..), isJust)
import Data.String (take)
import Data.String.Regex (Regex(), noFlags, regex, match, test)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Utils (stringToNumber, stringToInt)

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

isValue :: Semantics -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semantics -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semantics -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semantics -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semantics -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semantics -> Boolean
isTime (Time _) = true
isTime _ = false

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 (Time t) = t
printSemantics (Bool b) = show b

semanticsToNumber :: Semantics -> Maybe Number
semanticsToNumber (Value v) = pure v
semanticsToNumber (Money v _) = pure v
semanticsToNumber (Percent v) = pure v
semanticsToNumber _ = Nothing

-- | Used as accumulator in `checkPredicate` only
type CheckAccum =
  { correct :: Int
  , incorrect :: Int
  , filtered :: List (Maybe Semantics)
  }

emptyAccum :: CheckAccum
emptyAccum =
  { correct: zero
  , incorrect: zero
  , filtered: Nil
  }

-- | This function checks values in list of `Maybe Semantics` and
-- | returns a list with values that satisfies predicate wrapped in `Just`
-- | or (if there more incorrect values than correct) it returns `Nothing`
checkPredicate
  :: (Semantics -> Boolean) -> List (Maybe Semantics)
  -> Maybe (List (Maybe Semantics))
checkPredicate p lst = pureST do
  corrects <- newSTRef 0
  incorrects <- newSTRef 0
  filtered <- newSTRef Nil
  -- `traverse_` uses `foldr`. `List`s `foldr` isn't tail recursive.
  -- To make it tail recursive we probably should reimplement `foldr` like
  -- `foldr f init lst = reverse $ foldl (flip f) init $ reverse lst`
  -- and this make our optimization absolutely useless because of two
  -- `reverse`s. And this is worse then converting list to array before `traverse_`
  -- ```
  --  let arr :: Array _
  --      arr = L.fromList lst
  --  in traverse_ (checkPredicateTraverseFn p corrects incorrects filtered) arr
  -- ```
  foldl
    (\b a -> checkPredicateTraverseFn p corrects incorrects filtered a *> b)
    (pure unit) lst
  c <- readSTRef corrects
  ic <- readSTRef incorrects
  if c > ic
    then do
    f <- readSTRef filtered
    pure $ Just f
    else
    pure Nothing

checkPredicateTraverseFn
  :: forall h
   . (Semantics -> Boolean)
  -> STRef h Int -> STRef h Int -> STRef h (List (Maybe Semantics))
  -> Maybe Semantics -> Eff (st :: ST h) Unit
checkPredicateTraverseFn _ corrects incorrects filtered Nothing = do
  modifySTRef filtered (Cons Nothing)
  pure unit
checkPredicateTraverseFn p corrects incorrects filtered (Just c)
  | isUsedAsNothing c = do
    modifySTRef filtered $ Cons Nothing
    pure unit

  | p c = do
    modifySTRef filtered $ Cons $ Just c
    modifySTRef corrects (+ 1)
    pure unit

  | otherwise = do
    modifySTRef filtered $ Cons Nothing
    modifySTRef incorrects (+ 1)
    pure unit

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

instance semanthicShow :: Show Semantics where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semantics where
  eq (Value v) (Value v') = v == v'
  eq (Value v) _ = false
  eq (Percent p) (Percent p') = p == p'
  eq (Percent _) _ = false
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Money _ _) _ = false
  eq (Time t) (Time t') = t == t'
  eq (Time _) _ = false
  eq (Category c) (Category c') = c == c'
  eq (Category _) _ = false
  eq (Bool b) (Bool b') = b == b'
  eq (Bool _) _ = false

instance semanthicOrd :: Ord Semantics where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'
  compare (Category _) _ = LT
  compare (Bool b) (Bool b') = compare b b'
  compare (Bool _) _ = LT

analyze :: JsonPrim -> Maybe Semantics
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semantics
analyzeString str =
      analyzeDate str
  <|> analyzeNumber str
  <|> analyzeMoney str
  <|> analyzePercent str
  <|> (Just $ Category str)

analyzeNumber :: String -> Maybe Semantics
analyzeNumber s = do
  num <- stringToNumber s
  int <- stringToInt s
  guard $ show num == s || show int == s
  pure $ Value num

percentRegex :: Regex
percentRegex = regex """^(-?\d+(\.\d+)?)\%$""" 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 = regex rgxStr 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

dateRegex :: Regex
dateRegex = regex rgxStr 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]) (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])?$"

analyzeDate :: String -> Maybe Semantics
analyzeDate str = do
  guard $ test dateRegex str
  pure $ Time str

jsonToSemantics :: Json -> Map JCursor Semantics
jsonToSemantics j = fromList $ 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 = fromList $ 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

checkValues :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkValues = checkPredicate isValue

checkMoney :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkMoney = checkPredicate isMoney

checkPercent :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkPercent = checkPredicate isPercent

checkBool :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkBool = checkPredicate isBool

checkTime :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkTime = checkPredicate isTime

checkCategory :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkCategory = checkPredicate isCategory

instance encodeJsonSemantics :: EncodeJson Semantics where
  encodeJson (Value n) =
    "type" := "value" ~> "value" := n ~> jsonEmptyObject
  encodeJson (Percent p) =
    "type" := "percent" ~> "value" := p ~> jsonEmptyObject
  encodeJson (Money n v) =
    "type" := "money" ~> "currency" := v ~> "value" := n ~> jsonEmptyObject
  encodeJson (Bool b) =
    "type" := "bool" ~> "value" := b ~> jsonEmptyObject
  encodeJson (Category c) =
    "type" := "category" ~> "value" := c ~> jsonEmptyObject
  encodeJson (Time t) =
    "type" := "time" ~> "value" := t ~> jsonEmptyObject

instance decodeJsonSemantics :: DecodeJson Semantics where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    decode' ty obj
    where
    decode' "money" obj = do
      curr <- obj .? "currency"
      m <- obj .? "value"
      pure $ Money m curr
    decode' "time" obj = do
      t <- obj .? "value"
      pure $ Time t
    decode' "bool" obj = do
      b <- obj .? "value"
      pure $ Bool b
    decode' "category" obj = do
      c <- obj .? "value"
      pure $ Category c
    decode' "value" obj = do
      v <- obj .? "value"
      pure $ Value v
    decode' "percent" obj = do
      p <- obj .? "value"
      pure $ Percent p
    decode' _ _ = Left "incorrect type of semantics"

{-
Copyright 2015 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 Model.ChartSemantics where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad.Eff (Eff())
import Control.Monad.ST (STRef(), ST(), newSTRef, modifySTRef, readSTRef, pureST)
import Control.MonadPlus (guard)
import Data.Argonaut
  ( runJsonPrim, toPrims, JsonPrim(), Json(), JArray(), JCursor()
  , DecodeJson, EncodeJson, decodeJson, jsonEmptyObject, (:=), (.?), (~>))
import Data.Array as A
import Data.Array.ST
import Data.Either (Either(..))
import Data.Foldable (foldl, foldMap)
import Data.List (List(..), reverse, catMaybes, toList)
import Data.List as L
import Data.Map (Map(), keys, update, lookup, fromList)
import Data.Maybe (Maybe(..), isJust)
import Data.String (take)
import Data.String.Regex (Regex(), noFlags, regex, match, test)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Utils (stringToNumber, stringToInt)

data Semantics
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

isValue :: Semantics -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semantics -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semantics -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semantics -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semantics -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semantics -> Boolean
isTime (Time _) = true
isTime _ = false

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 (Time t) = t
printSemantics (Bool b) = show b

semanticsToNumber :: Semantics -> Maybe Number
semanticsToNumber (Value v) = pure v
semanticsToNumber (Money v _) = pure v
semanticsToNumber (Percent v) = pure v
semanticsToNumber _ = Nothing

-- | Used as accumulator in `checkPredicate` only
type CheckAccum =
  { correct :: Int
  , incorrect :: Int
  , filtered :: List (Maybe Semantics)
  }

emptyAccum :: CheckAccum
emptyAccum =
  { correct: zero
  , incorrect: zero
  , filtered: Nil
  }

-- | This function checks values in list of `Maybe Semantics` and
-- | returns a list with values that satisfies predicate wrapped in `Just`
-- | or (if there more incorrect values than correct) it returns `Nothing`
checkPredicate
  :: (Semantics -> Boolean) -> List (Maybe Semantics)
  -> Maybe (List (Maybe Semantics))
checkPredicate p lst = pureST do
  corrects <- newSTRef 0
  incorrects <- newSTRef 0
  filtered <- newSTRef Nil
  foldl
    (\_ a -> checkPredicateTraverseFn p corrects incorrects filtered a)
    (pure unit) lst
  c <- readSTRef corrects
  ic <- readSTRef incorrects
  if c > ic
    then do
    f <- readSTRef filtered
    pure $ Just f
    else
    pure Nothing

checkPredicateTraverseFn
  :: forall h
   . (Semantics -> Boolean)
  -> STRef h Int -> STRef h Int -> STRef h (List (Maybe Semantics))
  -> Maybe Semantics -> Eff (st :: ST h) Unit
checkPredicateTraverseFn _ corrects incorrects filtered Nothing = do
  modifySTRef filtered (Cons Nothing)
  pure unit
checkPredicateTraverseFn p corrects incorrects filtered (Just c)
  | isUsedAsNothing c = do
    modifySTRef filtered $ Cons Nothing
    pure unit

  | p c = do
    modifySTRef filtered $ Cons $ Just c
    modifySTRef corrects (+ 1)
    pure unit

  | otherwise = do
    modifySTRef filtered $ Cons Nothing
    modifySTRef incorrects (+ 1)
    pure unit

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

instance semanthicShow :: Show Semantics where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semantics where
  eq (Value v) (Value v') = v == v'
  eq (Value v) _ = false
  eq (Percent p) (Percent p') = p == p'
  eq (Percent _) _ = false
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Money _ _) _ = false
  eq (Time t) (Time t') = t == t'
  eq (Time _) _ = false
  eq (Category c) (Category c') = c == c'
  eq (Category _) _ = false
  eq (Bool b) (Bool b') = b == b'
  eq (Bool _) _ = false

instance semanthicOrd :: Ord Semantics where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'
  compare (Category _) _ = LT
  compare (Bool b) (Bool b') = compare b b'
  compare (Bool _) _ = LT

analyze :: JsonPrim -> Maybe Semantics
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semantics
analyzeString str =
      analyzeDate str
  <|> analyzeNumber str
  <|> analyzeMoney str
  <|> analyzePercent str
  <|> (Just $ Category str)

analyzeNumber :: String -> Maybe Semantics
analyzeNumber s = do
  num <- stringToNumber s
  int <- stringToInt s
  guard $ show num == s || show int == s
  pure $ Value num

percentRegex :: Regex
percentRegex = regex """^(-?\d+(\.\d+)?)\%$""" 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 = regex rgxStr 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

dateRegex :: Regex
dateRegex = regex rgxStr 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]) (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])?$"

analyzeDate :: String -> Maybe Semantics
analyzeDate str = do
  guard $ test dateRegex str
  pure $ Time str

jsonToSemantics :: Json -> Map JCursor Semantics
jsonToSemantics j = fromList $ 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 = fromList $ 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

checkValues :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkValues = checkPredicate isValue

checkMoney :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkMoney = checkPredicate isMoney

checkPercent :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkPercent = checkPredicate isPercent

checkBool :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkBool = checkPredicate isBool

checkTime :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkTime = checkPredicate isTime

checkCategory :: List (Maybe Semantics) -> Maybe (List (Maybe Semantics))
checkCategory = checkPredicate isCategory

instance encodeJsonSemantics :: EncodeJson Semantics where
  encodeJson (Value n) =
    "type" := "value" ~> "value" := n ~> jsonEmptyObject
  encodeJson (Percent p) =
    "type" := "percent" ~> "value" := p ~> jsonEmptyObject
  encodeJson (Money n v) =
    "type" := "money" ~> "currency" := v ~> "value" := n ~> jsonEmptyObject
  encodeJson (Bool b) =
    "type" := "bool" ~> "value" := b ~> jsonEmptyObject
  encodeJson (Category c) =
    "type" := "category" ~> "value" := c ~> jsonEmptyObject
  encodeJson (Time t) =
    "type" := "time" ~> "value" := t ~> jsonEmptyObject

instance decodeJsonSemantics :: DecodeJson Semantics where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    decode' ty obj
    where
    decode' "money" obj = do
      curr <- obj .? "currency"
      m <- obj .? "value"
      pure $ Money m curr
    decode' "time" obj = do
      t <- obj .? "value"
      pure $ Time t
    decode' "bool" obj = do
      b <- obj .? "value"
      pure $ Bool b
    decode' "category" obj = do
      c <- obj .? "value"
      pure $ Category c
    decode' "value" obj = do
      v <- obj .? "value"
      pure $ Value v
    decode' "percent" obj = do
      p <- obj .? "value"
      pure $ Percent p
    decode' _ _ = Left "incorrect type of semantics"


Remove `findOptionDesc` function

Remove `findOptionDesc` function

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  -- TODO
  -- Match f and then each f in fs up with a descrption, if any, returning
  -- an Docopt.Option for each.
  traverse match (f:toList fs)
  where
    match f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f <$> ds)

    toArg a = a >>= \an -> return $ OptionArgument an Nothing
    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> D.Desc -> Maybe Argument
    convert f (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | f == f'
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | f == f'
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

findOptionDesc :: List D.Desc -> U.Argument -> Maybe D.Desc
findOptionDesc ds (U.Option n _ _) = head $ filter matches ds
  where
    matches (D.OptionDesc (D.Option { name=(D.Long n')   })) = n == n'
    matches (D.OptionDesc (D.Option { name=(D.Full _ n') })) = n == n'
    matches _ = false
findOptionDesc ds (U.OptionStack n _ _ _) = head $ filter matches ds
  where
    matches _ = false
findOptionDesc _ _ = Nothing

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  -- TODO
  -- Match f and then each f in fs up with a descrption, if any, returning
  -- an Docopt.Option for each.
  traverse match (f:toList fs)
  where
    match f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f <$> ds)

    toArg a = a >>= \an -> return $ OptionArgument an Nothing
    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> D.Desc -> Maybe Argument
    convert f (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | f == f'
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | f == f'
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)