Correct comment

Correct comment

-- | 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', fromMaybe)
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 :: Boolean
debug = false

-- |
-- | 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) _ | 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
                          true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst canSkip
  = 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 canSkip
                            <* 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 branch to match
                -> Boolean   -- ^ Enable "options-first"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst canSkip = 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 (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

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

          -- Generate the parser for the argument `p`. For groups, temporarily
          -- set the required flag to "true", such that it will fail and we have
          -- a chance to retry as part of the exhaustive parsing mechanism
          r <- unScoredResult <$> (P.try $ genParser (D.setRequired p true)
                                                     (not $ n > 0))

          -- verify the arguments for the 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 missing = fst <$> flip filter r.result
                    (\(Tuple a v) -> (fromMaybe false do
                                        arg <- O.runArgument <$> do
                                                  D.getArgument a
                                        return $ not arg.optional
                                     )
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

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

          r' <- unScoredResult <$> P.try 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 :: StrMap String <- lift ask

          -- Find flags missing from the input.
          -- If we are explicitly allowed to skip arguments because of lack of
          -- input, or we have *at least* one match (i.e. the remainder is less
          -- than the original), then ignore arguments for which a suitable
          -- fallback value can be provided.
          let missing = filter (\o -> not $
                                  (canSkip || (length ps' < length ps))
                               && isSkippable env o
                               ) ps'

          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

          where
            isSkippable env (D.Group o bs _)
              = o || (all (all (isSkippable env) <<< D.runBranch) bs)
            isSkippable env o
              =  (D.isRepeatable  o)
              || (D.hasDefault    o)
              || (maybe true id do
                  arg <- O.runArgument <$> do
                            D.getArgument o
                  return arg.optional
                )
              || (D.hasEnvBacking o env)

        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)

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

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

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

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

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

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <$> 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 -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> 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) canSkip = 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
                                  -- always allow skipping for non-free groups.
                                  (not (isFree x) || canSkip)

          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
                                            -- always allow skipping for
                                            -- non-free groups.
                                            (not (isFree x) || canSkip)

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)                                           = true
    isFree (D.Group _ bs _) | all (all isFree <<< D.runBranch) bs = true
    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', fromMaybe)
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 :: Boolean
debug = false

-- |
-- | 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) _ | 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
                          true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst canSkip
  = 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 canSkip
                            <* 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"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst canSkip = 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 (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

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

          -- Generate the parser for the argument `p`. For groups, temporarily
          -- set the required flag to "true", such that it will fail and we have
          -- a chance to retry as part of the exhaustive parsing mechanism
          r <- unScoredResult <$> (P.try $ genParser (D.setRequired p true)
                                                     (not $ n > 0))

          -- verify the arguments for the 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 missing = fst <$> flip filter r.result
                    (\(Tuple a v) -> (fromMaybe false do
                                        arg <- O.runArgument <$> do
                                                  D.getArgument a
                                        return $ not arg.optional
                                     )
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

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

          r' <- unScoredResult <$> P.try 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 :: StrMap String <- lift ask

          -- Find flags missing from the input.
          -- If we are explicitly allowed to skip arguments because of lack of
          -- input, or we have *at least* one match (i.e. the remainder is less
          -- than the original), then ignore arguments for which a suitable
          -- fallback value can be provided.
          let missing = filter (\o -> not $
                                  (canSkip || (length ps' < length ps))
                               && isSkippable env o
                               ) ps'

          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

          where
            isSkippable env (D.Group o bs _)
              = o || (all (all (isSkippable env) <<< D.runBranch) bs)
            isSkippable env o
              =  (D.isRepeatable  o)
              || (D.hasDefault    o)
              || (maybe true id do
                  arg <- O.runArgument <$> do
                            D.getArgument o
                  return arg.optional
                )
              || (D.hasEnvBacking o env)

        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)

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

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

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

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

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

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <$> 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 -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> 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) canSkip = 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
                                  -- always allow skipping for non-free groups.
                                  (not (isFree x) || canSkip)

          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
                                            -- always allow skipping for
                                            -- non-free groups.
                                            (not (isFree x) || canSkip)

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)                                           = true
    isFree (D.Group _ bs _) | all (all isFree <<< D.runBranch) bs = true
    isFree _                                                      = false


code cleanup

code cleanup

module Main (main) where

import Control.Monad.Eff
import Data.Array
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Types
import DOM
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.String.Regex (regex, parseFlags, replace)
import Debug.Trace

import Types
import Transformer
import Solver
import Sortable
import Isomer

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

renderAll isomer = do
    doc <- document globalWindow
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    -- The following line could be simplified to:
    --   ids <- traverse (getAttribute "id") lis
    -- see https://github.com/aktowns/purescript-simple-dom/issues/25
    ids <- sequence $ map (getAttribute "id") lis
    let fs = mapMaybe getTransformerById ids
    let steps = allSteps fs initial

    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer target

    -- DEBUG:
    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace ""

replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

keyPress :: forall eff. HTMLDocument -> DOMEvent -> Eff (dom :: DOM | eff) Unit
keyPress doc event = do
    code <- keyCode event
    case code of
         -- 'g': generate new puzzle
         71 -> return unit
         -- 'r': reset lists
         82 -> resetUI doc
         _ -> return unit
    return unit

resetUI :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
resetUI doc = do
    Just ulAvailable <- getElementById "available" doc
    let html = mconcat $ map (\t -> "
" ++ replaceColors t.name ++ "
") transformers
    setInnerHTML html ulAvailable
    Just ulProgram <- getElementById "program" doc
    setInnerHTML "" ulProgram

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

target :: Wall
target = [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]

main = do
    isomer <- getIsomerInstance "canvas"

    -- install sortable
    doc <- document globalWindow

    let dummyHandler = return unit
    getElementById "available" doc >>= (\(Just el) -> installSortable el dummyHandler)
    getElementById "program" doc >>= (\(Just el) -> installSortable el (renderAll isomer))

    -- keyboard events
    addKeyboardEventListener KeydownEvent (keyPress doc) globalWindow

    resetUI doc
    renderAll isomer

module Main (main) where

import Control.Monad.Eff
import Data.Array
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Types
import DOM
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.String.Regex (regex, parseFlags, replace)
import Debug.Trace

import Types
import Transformer
import Solver
import Sortable
import Isomer

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

target :: Wall
target = [[Brown], [Yellow], [Yellow], [Yellow], [Brown]]

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

mapIndexed :: forall a b. (Number -> a -> b) -> [a] -> [b]
mapIndexed f xs = zipWith f (0 .. (length xs - 1)) xs

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    sequence_ $ mapIndexed (renderCube isomer x (-6 * y)) $ map cubeColor stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    sequence_ $ mapIndexed (\x stack -> renderStack isomer y (length wall - x) stack) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    sequence_ $ mapIndexed (renderWall isomer) walls

renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

renderAll isomer = do
    doc <- document globalWindow
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    ids <- sequence $ map (getAttribute "id") lis
    let fs = catMaybes $ map getTransformerById ids

    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show initial
    trace "Steps:"
    let steps = allSteps fs initial
    traverse_ (show >>> trace) steps
    trace "---"
    trace ""

    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer target

replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

keyPress :: forall eff. HTMLDocument -> DOMEvent -> Eff (dom :: DOM | eff) Unit
keyPress doc event = do
    code <- keyCode event
    case code of
         -- 'g': generate new puzzle
         71 -> return unit
         -- 'r': reset lists
         82 -> resetUI doc
         _ -> return unit
    return unit

resetUI :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
resetUI doc = do
    Just ulAvailable <- getElementById "available" doc
    let html = mconcat $ map (\t -> "
" ++ replaceColors t.name ++ "
") transformers
    setInnerHTML html ulAvailable
    Just ulProgram <- getElementById "program" doc
    setInnerHTML "" ulProgram

main = do
    isomer <- getIsomerInstance "canvas"

    -- install sortable
    doc <- document globalWindow

    let dummyHandler = return unit
    getElementById "available" doc >>= (\(Just el) -> installSortable el dummyHandler)
    getElementById "program" doc >>= (\(Just el) -> installSortable el (renderAll isomer))

    -- keyboard events
    addKeyboardEventListener KeydownEvent (keyPress doc) globalWindow

    resetUI doc
    renderAll isomer

    {-- -- test --}
    {-- let msol = solve initial (tStackEqual initial) --}
    {-- case msol of --}
    {--      Just sol -> do --}
    {--          let ids = map (\x -> x.id) sol --}
    {--          print ids --}


Simpler matching and rendering

Simpler matching and rendering

Original commit e62582be224b84909d650cf56547582735167c20

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (for_)

import Data.List as L
import Data.List ((:))
import Data.List.Types (List(..))

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: L.List IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (L.fromFoldable >>> case _ of
        Nil -> IRArray IRNothing
        Cons x _ -> IRArray $ makeTypeFromJson (singularize name) x)
    (\o -> IRClass { name, properties: mapProperties o })
    json

mapProperties :: StrMap.StrMap Json -> L.List IRProperty
mapProperties sm = StrMap.foldMap toProperty sm
  where toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType (IRClass classData@{ name, properties }) =
     classData : L.concatMap gatherClassesFromType (_.typ <$> properties)
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = empty

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = renderTypeToCSharp a <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> Doc Unit
renderClassToCSharp { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ properties \p -> line do
            string "public "
            string $ renderTypeToCSharp p.typ
            words ["", p.name, "{ get; set; }"]
    line "}"

renderClassesToCSharp :: L.List IRClassData -> Doc Unit
renderClassesToCSharp classes = for_ classes \cls -> do
    renderClassToCSharp cls
    blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp
    <#> render

module Main where

import Prelude

import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concatMap, foldMap, (!!), (:))
import Data.Either (Either)
import Data.Maybe (fromJust)
import Data.StrMap (StrMap, foldMap, fromFoldable, toUnfoldable, values) as StrMap
import Data.Tuple (Tuple(Tuple))
import Partial.Unsafe (unsafePartial)

type IRClassData = { name :: String, properties :: StrMap.StrMap IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (case _ of
        [] -> IRArray IRNothing
        a ->
            let elementType = makeTypeFromJson (singularize name) (unsafePartial $ fromJust $ a !! 0) in
            IRArray elementType)
    (\o -> IRClass { name, properties: mapProperties o })
    json

mapProperties :: StrMap.StrMap Json -> StrMap.StrMap IRType
mapProperties sm = StrMap.fromFoldable results
  where mapper (Tuple n j) = Tuple n (makeTypeFromJson n j)
        results = map mapper (unfold sm)

singularize :: String -> String
singularize s = "OneOf" <> s

-- This is a travesty.  Try putting this function definition
-- in the where clause below.
unfold :: forall a. StrMap.StrMap a -> Array (Tuple String a)
unfold sm = StrMap.toUnfoldable sm

gatherClassesFromType :: IRType -> Array IRClassData
gatherClassesFromType (IRClass classData) =
    let { name, properties } = classData in
    classData : (concatMap gatherClassesFromType (StrMap.values properties))
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = []

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = (renderTypeToCSharp a) <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> String
renderClassToCSharp { name, properties } =
    "class " <> name <> """
{""" <>
    StrMap.foldMap (\n -> \t -> "\n" <> nameToProperty n t) properties
    <> """
}
"""
    where nameToProperty name irType = "    public " <> (renderTypeToCSharp irType) <> " " <> name <> " { get; set; }"

renderClassesToCSharp :: Array IRClassData -> String
renderClassesToCSharp classes =
    foldMap (\c -> (renderClassToCSharp c) <> "\n\n") classes

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp


refine the code

refine the code

{-
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.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts as EC

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxises, colors, buildChartAxises, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

radarData ∷ ChartAxises → RadarData
radarData axises = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

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

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

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axises.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axises.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                (fromMaybe "" a)
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← L.head $ map fst x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← L.head $ map fst x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← L.head $ map fst x
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation a = case agg of
    Just agg' → runAggregation agg' a
    _ → runAggregation Sum a

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a =
    if (L.length $ snd a) == L.length distinctDims
      then Just $ Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
      else Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → EC.Option
buildRadar axises conf =
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , polar = Just polars
      , tooltip = Just tooltip
      , legend = Just $ legends
      , color = Just colors
      }
  where

  legends ∷ EC.Legend
  legends =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault serieNames
      , x = Just EC.XLeft
      , y = Just EC.YTop
      , orient = Just EC.Vertical
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    }

  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd extracted

  polars ∷ Array EC.Polar
  polars =
    let
      numPolar = A.length $ snd extracted
    in
      map (mkPolar numPolar) (A.range 0 $ numPolar - 1)
    where
    mkPolar ∷ Int → Int → EC.Polar
    mkPolar n i =
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      in
        EC.Polar EC.polarDefault
          { indicator = Just $ mkIndicatorSet i
          , center = Just $ Tuple
                            ( EC.Percent (100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))) )
                            ( EC.Percent (100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))) )
          , radius = Just $ EC.Percent (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
          }

  mkIndicatorSet ∷ Int → Array EC.Indicator
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd extracted) !! i
    in
      map (mkIndicator dupName) (fst extracted)

  mkIndicator ∷ String → String → EC.Indicator
  mkIndicator dupName dim =
    EC.Indicator EC.indicatorDefault
      { text = Just $ dupName <> (if dupName == "" then "" else ": ") <> dim
      , min = minVal
      , max = maxVal
      }

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd extracted

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  series ∷ Array EC.Series
  series = mkSeries extracted

  extracted ∷ RadarData
  extracted = radarData $ buildChartAxises axises conf

mkSeries
  ∷ RadarData
  → (Array EC.Series)
mkSeries rData =
  map serie (A.zip (A.range 0 ((A.length $ snd rData) - 1)) (snd rData))
  where
  serie
    ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
    → EC.Series
  serie (Tuple ind (Tuple dup a)) =
    EC.RadarSeries
      { common: EC.universalSeriesDefault
        { name = guard (dup /= "") $> dup
        , tooltip = if A.null a
                    then Just $ EC.Tooltip $ EC.tooltipDefault
                      -- To overwrite the top tooltip display config.
                      -- Other configurations here cannot overwrite the top one,
                      -- maybe due to some echarts' bugs
                      { trigger = Just EC.TriggerItem
                      , formatter = Just $ EC.Template " "
                      , show = Just false }
                    else Nothing
        }
      , radarSeries: EC.radarSeriesDefault
        { polarIndex = Just $ toNumber ind
        , "data" = Just if A.null a
                   then [blankData]
                   else map makeData a
        , symbol = Just if A.null a
                   then EC.NoSymbol
                   else EC.Circle
        }
      }

  makeData
    ∷ Tuple String (Array Number)
    → EC.ItemData
  makeData (Tuple name values) = EC.Dat
    { name: Just name
    , value: EC.Many values
    , tooltip: Nothing
    , itemStyle: Nothing
    , selected: Nothing
    }

  blankData ∷ EC.ItemData
  blankData = EC.Dat
    { name: Nothing
      -- set a value to avoid display issue
    , value: EC.Many [0.0]
    , tooltip: Just $ EC.Tooltip $ EC.tooltipDefault
      { show = Just false }
    , itemStyle: Nothing
    , selected: Nothing
    }

{-
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.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts as EC

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxises, colors, buildChartAxises, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

radarData ∷ ChartAxises → RadarData
radarData axises = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axises.dimensions !! 0

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

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

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axises.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axises.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                ( case a of
                    Just a' → a'
                    _ → ""
                )
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← L.head $ map fst x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← L.head $ map fst x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← (L.head $ map fst x)
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation a = case agg of
    Just agg' → runAggregation agg' a
    _ → runAggregation Sum a

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a = case (L.length $ snd a) == L.length distinctDims of
    true → Just $
      Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
    _ → Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → EC.Option
buildRadar axises conf =
    EC.Option EC.optionDefault
      { series = Just $ map Just series
      , polar = Just polars
      , tooltip = Just tooltip
      , legend = Just $ legends
      , color = Just colors
      }
  where

  legends ∷ EC.Legend
  legends =
    EC.Legend EC.legendDefault
      { "data" = Just $ map EC.legendItemDefault serieNames
      , x = Just EC.XLeft
      , y = Just EC.YTop
      , orient = Just EC.Vertical
      , textStyle = Just $ EC.TextStyle EC.textStyleDefault
          { fontFamily = Just "Ubuntu" }
      }

  tooltip ∷ EC.Tooltip
  tooltip = EC.Tooltip $ EC.tooltipDefault
    { trigger = Just EC.TriggerAxis
    , textStyle = Just $ EC.TextStyle EC.textStyleDefault
        { fontFamily = Just "Ubuntu"
        , fontSize = Just 12.0
        }
    }

  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd extracted

  polars ∷ Array EC.Polar
  polars =
    let
      numPolar = A.length $ snd extracted
    in
      map (mkPolar numPolar) (A.range 0 $ numPolar - 1)
    where
    mkPolar ∷ Int → Int → EC.Polar
    mkPolar n i =
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      in
        EC.Polar EC.polarDefault
          { indicator = Just $ mkIndicatorSet i
          , center = Just $ Tuple
                            ( EC.Percent (100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))) )
                            ( EC.Percent (100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))) )
          , radius = Just $ EC.Percent (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
          }

  mkIndicatorSet ∷ Int → Array EC.Indicator
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd extracted) !! i
    in
      map (mkIndicator dupName) (fst extracted)

  mkIndicator ∷ String → String → EC.Indicator
  mkIndicator dupName dim =
    EC.Indicator EC.indicatorDefault
      { text = Just $ dupName <> (if dupName == "" then "" else ": ") <> dim
      , min = minVal
      , max = maxVal
      }

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd extracted

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  series ∷ Array EC.Series
  series = mkSeries extracted

  extracted ∷ RadarData
  extracted = radarData $ buildChartAxises axises conf

mkSeries
  ∷ RadarData
  → (Array EC.Series)
mkSeries rData =
  map serie (A.zip (A.range 0 ((A.length $ snd rData) - 1)) (snd rData))
  where
  serie
    ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
    → EC.Series
  serie (Tuple ind (Tuple dup a)) =
    EC.RadarSeries
      { common: EC.universalSeriesDefault
        { name = guard (dup /= "") $> dup
        , tooltip = if A.null a
                    then Just $ EC.Tooltip $ EC.tooltipDefault
                      -- To overwrite the top tooltip display config.
                      -- Other configurations here cannot overwrite the top one,
                      -- maybe due to some echarts' bugs
                      { trigger = Just EC.TriggerItem
                      , formatter = Just $ EC.Template " "
                      , show = Just false }
                    else Nothing
        }
      , radarSeries: EC.radarSeriesDefault
        { polarIndex = Just $ toNumber ind
        , "data" = Just if A.null a
                   then [blankData]
                   else map makeData a
        , symbol = Just if A.null a
                   then EC.NoSymbol
                   else EC.Circle
        }
      }

  makeData
    ∷ Tuple String (Array Number)
    → EC.ItemData
  makeData (Tuple name values) = EC.Dat
    { name: Just name
    , value: EC.Many values
    , tooltip: Nothing
    , itemStyle: Nothing
    , selected: Nothing
    }

  blankData ∷ EC.ItemData
  blankData = EC.Dat
    { name: Nothing
      -- set a value to avoid display issue
    , value: EC.Many [0.0]
    , tooltip: Just $ EC.Tooltip $ EC.tooltipDefault
      { show = Just false }
    , itemStyle: Nothing
    , selected: Nothing
    }


removing Rows/Columns also unassigns Topics

module Openspace.Engine where

import Openspace.Types
import Data.Maybe
import qualified Data.Map as M
import Data.Tuple
import Data.Array

evalAction :: Action -> AppState -> AppState
evalAction (AddTopic t) as      = addTopic t as
evalAction (DeleteTopic t) as   = deleteTopic t as
evalAction (AddRoom r) as       = addRoom r as
evalAction (DeleteRoom r) as    = deleteRoom r as
evalAction (AddBlock b) as      = addBlock b as
evalAction (DeleteBlock b) as   = deleteBlock b as
evalAction (AssignTopic s t) as = addTimeslot s t as
evalAction (UnassignTopic t) as = let topicslotFilter = filter (\(Tuple _ t') -> t' /= t)
                                  in as {timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
evalAction (ShowError e) as     = as
evalAction NOP as               = as

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = as { timeslots = M.insert s t as.timeslots }

deleteTimeslot :: Slot -> AppState -> AppState
deleteTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

deleteTopic :: Topic -> AppState -> AppState
deleteTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

addRoom :: Room -> AppState -> AppState
addRoom r as = as { rooms = r : as.rooms }

deleteRoom :: Room -> AppState -> AppState
deleteRoom r as = as { rooms = filter (\r' -> r' /= r ) as.rooms
                     , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.room /= r)

addBlock :: Block -> AppState -> AppState
addBlock b as = as { blocks = b : as.blocks }

deleteBlock :: Block -> AppState -> AppState
deleteBlock b as = as { blocks = filter (\b' -> b' /= b ) as.blocks
                      , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
  where topicslotFilter = filter (\(Tuple (Slot s) _) -> s.block /= b)

module Openspace.Engine where

import Openspace.Types
import Data.Maybe
import qualified Data.Map as M
import Data.Tuple
import Data.Array

evalAction :: Action -> AppState -> AppState
evalAction (AddTopic t) as      = addTopic t as
evalAction (DeleteTopic t) as   = deleteTopic t as
evalAction (AddRoom r) as       = addRoom r as
evalAction (DeleteRoom r) as    = deleteRoom r as
evalAction (AddBlock b) as      = addBlock b as
evalAction (DeleteBlock b) as   = deleteBlock b as
evalAction (AssignTopic s t) as = addTimeslot s t as
evalAction (UnassignTopic t) as = let topicslotFilter = filter (\(Tuple _ t') -> t' /= t)
                                  in as {timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)}
evalAction (ShowError e) as     = as
evalAction NOP as               = as

addTimeslot :: Slot -> Topic -> AppState -> AppState
addTimeslot s t as = as { timeslots = M.insert s t as.timeslots }

deleteTimeslot :: Slot -> AppState -> AppState
deleteTimeslot s as = as { timeslots = M.delete s as.timeslots }

addTopic :: Topic -> AppState -> AppState
addTopic t as = as { topics = t:as.topics}

deleteTopic :: Topic -> AppState -> AppState
deleteTopic t as = let topicslotFilter = filter (\(Tuple s t') -> t' /= t)
                   in as { topics    = delete t as.topics
                         , timeslots = M.fromList $ topicslotFilter (M.toList as.timeslots)
                         }

addRoom :: Room -> AppState -> AppState
addRoom r as = as { rooms = r : as.rooms }

deleteRoom :: Room -> AppState -> AppState
deleteRoom r as = as { rooms = filter (\r' -> r' /= r ) as.rooms }

addBlock :: Block -> AppState -> AppState
addBlock b as = as { blocks = b : as.blocks }

deleteBlock :: Block -> AppState -> AppState
deleteBlock b as = as { blocks = filter (\b' -> b' /= b ) as.blocks }


Remove unused import

Remove unused import

module Control.Monad.Reader.Trans where

import Prelude
import Control.Monad.Trans

data ReaderT r m a = ReaderT (r -> m a)

runReaderT :: forall r m a. ReaderT r m a -> (r -> m a)
runReaderT (ReaderT x) = x

withReaderT :: forall r1 r2 m a b. (r2 -> r1) -> ReaderT r1 m a -> ReaderT r2 m a
withReaderT f m = ReaderT $ runReaderT m <<< f

mapReaderT :: forall r m1 m2 a b. (m1 a -> m2 b) -> ReaderT r m1 a -> ReaderT r m2 b
mapReaderT f m = ReaderT $ f <<< runReaderT m

liftReaderT :: forall r m a. m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)

instance monadReaderT :: (Monad m) => Monad (ReaderT r m) where
  return x = ReaderT \_ -> return x
  (>>=) m k = ReaderT \r -> do
    a <- runReaderT m r
    runReaderT (k a) r

instance appReaderT :: (Applicative m) => Applicative (ReaderT r m) where
  pure = liftReaderT <<< pure
  (<*>) f v = ReaderT \r -> runReaderT f r <*> runReaderT v r

instance altReaderT :: (Alternative m) => Alternative (ReaderT r m) where
  empty = liftReaderT empty
  (<|>) m n = ReaderT \r -> runReaderT m r <|> runReaderT n r

instance functorReaderT :: (Functor m) => Functor (ReaderT r m) where
  (<$>) f = mapReaderT $ (<$>) f

instance monadTransReaderT :: MonadTrans (ReaderT r) where
  lift = liftReaderT

module Control.Monad.Reader.Trans where

import Prelude
import Control.Monad
import Control.Monad.Trans

data ReaderT r m a = ReaderT (r -> m a)

runReaderT :: forall r m a. ReaderT r m a -> (r -> m a)
runReaderT (ReaderT x) = x

withReaderT :: forall r1 r2 m a b. (r2 -> r1) -> ReaderT r1 m a -> ReaderT r2 m a
withReaderT f m = ReaderT $ runReaderT m <<< f

mapReaderT :: forall r m1 m2 a b. (m1 a -> m2 b) -> ReaderT r m1 a -> ReaderT r m2 b
mapReaderT f m = ReaderT $ f <<< runReaderT m

liftReaderT :: forall r m a. m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)

instance monadReaderT :: (Monad m) => Monad (ReaderT r m) where
  return x = ReaderT \_ -> return x
  (>>=) m k = ReaderT \r -> do
    a <- runReaderT m r
    runReaderT (k a) r

instance appReaderT :: (Applicative m) => Applicative (ReaderT r m) where
  pure = liftReaderT <<< pure
  (<*>) f v = ReaderT \r -> runReaderT f r <*> runReaderT v r

instance altReaderT :: (Alternative m) => Alternative (ReaderT r m) where
  empty = liftReaderT empty
  (<|>) m n = ReaderT \r -> runReaderT m r <|> runReaderT n r

instance functorReaderT :: (Functor m) => Functor (ReaderT r m) where
  (<$>) f = mapReaderT $ (<$>) f

instance monadTransReaderT :: MonadTrans (ReaderT r) where
  lift = liftReaderT


added 'tryGet' into PouchDB bindings

added 'tryGet' into PouchDB bindings

module Libs.PouchDB where

import Control.Monad.Aff
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Error.Class
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Prelude

readForeignAff :: forall e a. (IsForeign a) => Foreign -> Aff e a
readForeignAff fr =
  case read fr of
    Left (JSONError msg) ->
      throwError $ error msg
    Left _ ->
      throwError $ error "Unknown error"
    Right result ->
      return result

foreign import data POUCHDB :: !

foreign import data PouchDB :: *

type PouchDBEff e a =
  Eff (pouchdb :: POUCHDB | e) a

type PouchDBAff e a =
  Aff (pouchdb :: POUCHDB | e) a

type PouchDBCallbackFFI e a =
  (Error -> PouchDBEff e Unit) -> (a -> PouchDBEff e Unit) -> PouchDBEff e Unit

foreign import newPouchDB :: forall e. String -> PouchDBEff e PouchDB

type PutResponse =
  { ok :: Boolean
  , id :: String
  , rev :: String
  }

data PutResponseFFI = PutResponseFFI PutResponse

instance putResponseIsForeign :: IsForeign PutResponseFFI where
  read o = do
    okVal <- readProp "ok" o
    idVal <- readProp "id" o
    revVal <- readProp "rev" o
    return $ PutResponseFFI
      { ok: okVal
      , id: idVal
      , rev: revVal
      }

foreign import putFFI :: forall e. PouchDB -> String -> Maybe String -> Foreign -> PouchDBCallbackFFI e Foreign

put :: forall a e. PouchDB -> String -> Maybe String -> a -> PouchDBAff e PutResponse
put db docId docRev doc = do
  foreignResult <- makeAff $ putFFI db docId docRev $ toForeign doc
  (PutResponseFFI result) <- readForeignAff foreignResult
  return result

foreign import postFFI :: forall e. PouchDB -> Foreign -> PouchDBCallbackFFI e Foreign

post :: forall a e. PouchDB -> a -> PouchDBAff e PutResponse
post db doc = do
  foreignResult <- makeAff $ postFFI db $ toForeign doc
  (PutResponseFFI result) <- readForeignAff foreignResult
  return result

foreign import getFFI :: forall e. PouchDB -> String -> PouchDBCallbackFFI e Foreign

get :: forall a e. (IsForeign a)  => PouchDB -> String -> PouchDBAff e a
get db docId =
  makeAff (getFFI db docId) >>= readForeignAff

tryGet :: forall a e. (IsForeign a) => PouchDB -> String -> PouchDBAff e (Maybe a)
tryGet db docId = do
  result <- attempt $ get db docId
  return $ either (const Nothing) Just result