Made Gonimo.Pux working for lenses also

Made Gonimo.Pux working for lenses also

+ convenience functions

-- | Gonimo specific Pux helpers and replacements for defaults.

module Gonimo.Pux where

import Prelude
import Data.Array as Arr
import Gonimo.Client.Types as Gonimo
import Control.Alternative (empty, class Alternative)
import Control.Monad.Aff (Aff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (class MonadIO, liftIO)
import Control.Monad.Maybe.Trans (runMaybeT, MaybeT(MaybeT))
import Control.Monad.Reader.Class (ask, local, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT(ReaderT))
import Control.Monad.State (State)
import Control.Monad.State.Class (modify, put, get, state, class MonadState)
import Control.Monad.State.Trans (runStateT, StateT(StateT))
import Control.Monad.Trans (lift, class MonadTrans)
import Data.Bifunctor (bimap, class Bifunctor)
import Data.Identity (runIdentity)
import Data.Lens (SetterP, (.=), prism, (^?), TraversalP, (.~), (^.), LensP)
import Data.Maybe (maybe, Maybe(Just, Nothing))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoEff, Gonimo, Settings, class ReportErrorAction)
import Gonimo.Util (fromMaybeM, runIOToSomeAff)
import Partial.Unsafe (unsafeCrashWith)
import Pux (noEffects, EffModel)

type Props ps = { settings :: Settings | ps }

-- First this was a record but records containing prisms is something psc does not seem to like.
-- | A helper data structure for transforming child components to parent components:
data ChildData parentState childState childProps =
  ChildData (TraversalP parentState childState) childProps

makeChildData :: forall parentState childState childProps. TraversalP parentState childState -> childProps -> (ChildData parentState childState childProps)
makeChildData fromToParent props = ChildData fromToParent props

childDataFromToParent :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> TraversalP parentState childState
childDataFromToParent (ChildData fromToParent _) = fromToParent

childDataProps :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> childProps
childDataProps (ChildData _ props) = props

-- | Create ChildData from a parent component:
type ToChild parentProps parentState childProps childState =
  Component parentProps parentState (ChildData parentState childState childProps)

-- | A component is just a Reader monad with react style props and a State monad
-- | with well our component state.
newtype Component props state a = Component (ReaderT props (State state) a)

-- | Generic type which depends on MonadComponent instead on a concrete Component.
-- | Also it assumes a monadic value of type `Array (IO Action)`
-- type ComponentType props state action = forall m. MonadComponent props state m => m (Array (IO action))
type ComponentType props state action = Component props state (Array (IO action))

-- | Stateful Update function which can be converted to a Pux eff model ...
-- I think we need fundeps for this to work properly in client code:
-- type Update props state action = forall m. (MonadComponent props state m)
--                                  => action -> m (Array (IO action))
type Update props state action = action -> ComponentType props state action

-- | Concrete instance for Update
type UpdateComponent props state action = action -> Component props state (Array (IO action))

runComponent :: forall props state a. Component props state a -> ReaderT props (State state) a
runComponent (Component m) = m

runComponentFull :: forall props state a. props -> state -> Component props state a -> Tuple a state
runComponentFull props state = runIdentity <<< flip runStateT state <<< flip runReaderT props <<< runComponent

-- | Run a child component and transform it to a parent component, updating the
-- | state only if it actually changed.
-- | We return Nothing if the child is currently not present in the parent.
liftChild :: forall childProps childState parentProps parentState a.
             ToChild parentProps parentState childProps childState
            -> Component childProps childState a
            -> Component parentProps parentState (Maybe a)
liftChild toChild child = do
  childData <- toChild
  oldParent <- get
  let
    fromToParent = childDataFromToParent childData
    childProps   = childDataProps childData

    runComponentCheck oldChild = do
      case runComponentFull childProps oldChild child of
        Tuple a newChild -> do
          when (differentObject newChild oldChild)
            $ fromToParent .= newChild
          pure a
  traverse runComponentCheck (oldParent ^? fromToParent)

-- | Convert a component to an EffModel usable with Pux.
-- | The restriction to of props to Unit for this root component is currently not justified
-- | and can be dropped if necessary. I just have some vague idea for future enhancements where
-- | properties for the root level component could be in the way.
toEffModel :: forall state action eff. state -> Component Unit state (Array (IO action)) -> EffModel state action eff
toEffModel initState c =
  case runComponentFull unit initState c of
    Tuple effects state -> { state : state
                           , effects : runIOToSomeAff <$> effects
                           }

-- | We are still using Pux - so let's a get a Pux like Update function which provides an EffModel ...
toPux :: forall state action eff. Update Unit state action -> action -> state -> EffModel state action eff
toPux update action state = toEffModel state $ update action

runGonimos :: forall action eff ps m
               . ( ReportErrorAction action
                 , MonadReader (Props ps) m
                 )
               => Array (Gonimo eff action) -> m (Array (IO action))
runGonimos effects = do
  props <- ask
  pure (Gonimo.toIO props.settings <$> effects)

runGonimo :: forall action eff ps m
               . ( ReportErrorAction action
                 , MonadReader (Props ps) m
                 )
               => Gonimo eff action -> m (Array (IO action))
runGonimo effect = do
  props <- ask
  pure $ [ Gonimo.toIO props.settings effect ]

-- | Only modify state, but trigger no effects:
onlyModify :: forall state action m . ( MonadState state m)
             => (state -> state) -> m (Array (IO action))
onlyModify  f = modify f *> pure []

noEffects :: forall m a. (Applicative m) => m (Array a)
noEffects = pure []

wrapAction :: forall action. action -> Array (IO action)
wrapAction = Arr.singleton <<< pure

toParent :: forall childAction parentAction parentProps parentState.
                  parentAction
                  -> (childAction -> parentAction)
                  -> Component parentProps parentState (Maybe (Array (IO childAction)))
                  -> Component parentProps parentState (Array (IO parentAction))
toParent onNothing mkAction child = maybe (wrapAction onNothing) (map (map mkAction)) <$> child

toParentM :: forall childAction parentAction parentProps parentState.
                  Component parentProps parentState (Array (IO parentAction))
                  -> (childAction -> parentAction)
                  -> Component parentProps parentState (Maybe (Array (IO childAction)))
                  -> Component parentProps parentState (Array (IO parentAction))
toParentM onNothing mkAction child = fromMaybeM onNothing <<< map (map (map (map mkAction))) $ child

class (MonadReader props m, MonadState state m) <= MonadComponent props state m

instance monadComponentComponent :: MonadComponent props state (Component props state)

instance functorComponent :: Functor (Component props state) where
  map f (Component m) = Component $ map f m

instance applyComponent :: Apply (Component props state) where
  apply (Component mf) (Component ma) = Component $ apply mf ma

instance applicativeComponent :: Applicative (Component props state) where
  pure = Component <<< pure

instance bindComponent :: Bind (Component props state) where
  bind (Component ma) mf = Component $ bind ma (runComponent <<< mf)

instance monadComponent :: Monad (Component props state)

instance monadReaderPropsComponent :: MonadReader props (Component props state) where
  ask = Component ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Component ma) = Component (local f ma)

instance monadStateStateComponent :: MonadState state (Component props state) where
  -- get = Component <<< MaybeT <<< runMaybeT <<< ReaderT <<< flip runReaderT
  --       <<< StateT $ \ s -> runStateT (pure s) s
  state f = Component $ state f

foreign import differentObject :: forall a b. a -> b -> Boolean

-- | Gonimo specific Pux helpers and replacements for defaults.

module Gonimo.Pux where

import Prelude
import Gonimo.Client.Types as Gonimo
import Control.Alternative (empty, class Alternative)
import Control.Monad.Aff (Aff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (class MonadIO, liftIO)
import Control.Monad.Maybe.Trans (runMaybeT, MaybeT(MaybeT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT(ReaderT))
import Control.Monad.State (State)
import Control.Monad.State.Class (modify, put, get, state, class MonadState)
import Control.Monad.State.Trans (runStateT, StateT(StateT))
import Control.Monad.Trans (lift, class MonadTrans)
import Data.Bifunctor (bimap, class Bifunctor)
import Data.Identity (runIdentity)
import Data.Lens (SetterP, APrismP, (.=), prism, (^?), PrismP, (.~), (^.), LensP)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoEff, Gonimo, Settings, class ReportErrorAction)
import Partial.Unsafe (unsafeCrashWith)
import Gonimo.Util (runIOToSomeAff)

-- First this was a record but records containing prisms is something psc does not seem to like.
-- | A helper data structure for transforming child components to parent components:
data ChildData parentState childState childProps =
  ChildData (PrismP parentState childState) childProps

makeChildData :: forall parentState childState childProps. PrismP parentState childState -> childProps -> (ChildData parentState childState childProps)
makeChildData fromToParent props = ChildData fromToParent props

childDataFromToParent :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> PrismP parentState childState
childDataFromToParent (ChildData fromToParent _) = fromToParent

childDataProps :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> childProps
childDataProps (ChildData _ props) = props

-- | Create ChildData from a parent component:
type ToChild parentProps parentState childProps childState m =
  (MonadReader parentProps m, MonadState parentState m)
  => m (ChildData parentState childState childProps)

-- | A component is just a Reader monad with react style props and a State monad
-- | with well our component state.
newtype Component props state a = Component (ReaderT props (State state) a)

-- | Stateful Update function which can be converted to a Pux eff model ...
type Update props state action = action -> Component props state (Array (IO action))

runComponent :: forall props state a. Component props state a -> ReaderT props (State state) a
runComponent (Component m) = m

runComponentFull :: forall props state a. props -> state -> Component props state a -> Tuple a state
runComponentFull props state = runIdentity <<< flip runStateT state <<< flip runReaderT props <<< runComponent

-- | Run a child component and transform it to a parent component, updating the
-- | state only if it actually changed.
-- | We return Nothing if the child is currently not present in the parent.
liftChild :: forall childProps childState parentProps parentState m a.
            ( MonadReader parentProps m
            , MonadState parentState m
            )
            => ToChild parentProps parentState childProps childState m
            -> Component childProps childState a
            -> m (Maybe a)
liftChild toChild child = do
  childData <- toChild
  oldParent <- get
  let
    fromToParent = childDataFromToParent childData
    childProps   = childDataProps childData

    runComponentCheck :: childState -> m a
    runComponentCheck oldChild = do
      case runComponentFull childProps oldChild child of
        Tuple a newChild -> do
          when (differentObject newChild oldChild)
            $ fromToParent .= newChild
          pure a
  traverse runComponentCheck (oldParent ^? fromToParent)

-- | Convert a component to an EffModel usable with Pux.
-- | The restriction to of props to Unit for this root component is currently not justified
-- | and can be dropped if necessary. I just have some vague idea for future enhancements where
-- | properties for the root level component could be in the way.
toEffModel :: forall state action eff. state -> Component Unit state (Array (IO action)) -> EffModelImpl state action eff
toEffModel initState c =
  case runComponentFull unit initState c of
    Tuple effects state -> { state : state
                           , effects : runIOToSomeAff <$> effects
                           }

-- | We are still using Pux - so let's a get a Pux like Update function which provides an EffModel ...
toPuxUpdate :: forall state action eff. Update Unit state action -> action -> state -> EffModelImpl state action eff
toPuxUpdate update action state = toEffModel state $ update action

instance functorComponent :: Functor (Component props state) where
  map f (Component m) = Component $ map f m

instance applyComponent :: Apply (Component props state) where
  apply (Component mf) (Component ma) = Component $ apply mf ma

instance applicativeComponent :: Applicative (Component props state) where
  pure = Component <<< pure

instance bindComponent :: Bind (Component props state) where
  bind (Component ma) mf = Component $ bind ma (runComponent <<< mf)

instance monadComponent :: Monad (Component props state)

instance monadReaderPropsComponent :: MonadReader props (Component props state) where
  ask = Component ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Component ma) = Component (local f ma)

instance monadStateStateComponent :: MonadState state (Component props state) where
  -- get = Component <<< MaybeT <<< runMaybeT <<< ReaderT <<< flip runReaderT
  --       <<< StateT $ \ s -> runStateT (pure s) s
  state f = Component $ state f

type EffModelImpl state action eff =
  { state :: state
  , effects :: Array (Aff (GonimoEff eff) action)
  }

newtype EffModel eff state action = EffModel (EffModelImpl state action eff)

runEffModel :: forall state action eff. EffModel eff state action -> EffModelImpl state action eff
runEffModel (EffModel model) = model

instance bifunctorEffModelEff :: Bifunctor (EffModel eff) where
  bimap f g (EffModel model) = EffModel
    { state : f model.state
    , effects : map (map g) model.effects
    }

updateChild :: forall eff parentState childState parentAction childAction props.
            LensP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> EffModel eff parentState parentAction
updateChild lens mkAction childUpdate props action state =
    bimap smartUpdate mkAction $ childUpdate props action (state ^. lens)
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild =if differentObject newChild (state ^. lens)
                          then state # lens .~ newChild
                          else  state

updatePrismChild :: forall eff parentState childState parentAction childAction props.
            PrismP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> Maybe (EffModel eff parentState parentAction)
updatePrismChild prism mkAction childUpdate props action state =
    bimap smartUpdate mkAction <<< childUpdate props action <$> state ^? prism
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild = case state ^? prism of
                                Nothing -> state
                                Just oldChild -> if differentObject newChild oldChild
                                                    then state # prism .~ newChild
                                                    else state

-- toParent :: forall eff parentState childState parentAction childAction.
--             LensP parentState childState
--             -> (childAction -> parentAction)
--             -> parentState -> EffModel eff childState childAction
--             -> EffModel eff parentState parentAction
-- toParent lens mkAction state = bimap smartUpdate mkAction
--   where
--     smartUpdate :: childState -> parentState
--     smartUpdate newChild = if differentObject newChild (state ^. lens)
--                            then lens .~ newChild $ state
--                            else state

onlyEffects :: forall state action eff
               .  state -> Array (Aff (GonimoEff eff) action)
               -> EffModel eff state action
onlyEffects state effects = EffModel { state : state
                                     , effects : effects
                                     }

-- | Like `onlyEffects` but for a single effect
onlyEffect :: forall state action eff
               . state -> Aff (GonimoEff eff) action
               -> EffModel eff state action
onlyEffect state eff = onlyEffects state [eff]

-- | Like onlyEffects but with arguments flipped
justEffects :: forall state action eff
               .  Array (Aff (GonimoEff eff) action)
               -> state -> EffModel eff state action
justEffects = flip onlyEffects

-- | Like `justEffects` but for a single effect
justEffect :: forall state action eff
               .  Aff (GonimoEff eff) action
               -> state -> EffModel eff state action
justEffect eff = justEffects [eff]

noEffects :: forall state action eff. state -> EffModel eff state action
noEffects state = EffModel { state : state, effects : [] }

type Props ps = { settings :: Settings | ps }

onlyGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Array (Gonimo eff action)
               -> EffModel eff state action
onlyGonimos props state = onlyEffects state <<< map (Gonimo.toAff props.settings)

-- | Like `onlyGonimos` but for a single effect
onlyGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Gonimo eff action
               -> EffModel eff state action
onlyGonimo props state eff = onlyGonimos props state [eff]

-- | Like onlyGonimos but with arguments flipped
justGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Array (Gonimo eff action)
               -> state -> EffModel eff state action
justGonimos props = flip $ onlyGonimos props

-- | Like `justGonimos` but for a single effect
justGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Gonimo eff action
               -> state -> EffModel eff state action
justGonimo props eff = justGonimos props [eff]

-- | Convert an our EffModel using update function to one usable for Pux.Config
toPux :: forall state action eff. (action -> state -> EffModel eff state action)
         -> action -> state -> EffModelImpl state action eff
toPux ours action state = runEffModel $ ours action state

foreign import differentObject :: forall a b. a -> b -> Boolean


simply encoder notation by using argonaut's operators

module Ifrit.Core where

import Prelude

import Data.Argonaut.Core(Json, stringify, isArray, isString, isBoolean, isNumber, foldJson)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson, (:=), (~>))
import Data.Array(concat, head, length, snoc)
import Data.Either(Either(..))
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap(StrMap, fromFoldable)
import Data.Traversable(traverse)
import Data.Tuple(Tuple(..))

import Ifrit.Decoder(decode2, decode3, decode4)

-- TYPES
data Terminal
  = Field String
  | ConstantString String
  | ConstantBoolean Boolean
  | ConstantNumber Number

data Filter
  = Eq (Array Terminal)
  | Neq (Array Terminal)
  | Lt (Array Terminal)
  | Gt (Array Terminal)
  | Or (Array Filter)
  | And (Array Filter)

data Map
  = Project Terminal
  | Inject Terminal Reduce
  | Add (Array Terminal)
  | Abs Terminal
  | Ceil Terminal
  | Div (Array Terminal)
  | Floor Terminal
  | Mult (Array Terminal)

data Reduce
  = Avg Terminal
  | Min Terminal
  | Max Terminal
  | Sum Terminal

data Stage
  = Map (Maybe Filter) (StrMap Map)
  | Reduce (Maybe Terminal) (StrMap Reduce)

type Pipeline =
  Array Stage

data JsonSchema
  = JObject (StrMap JsonSchema)
  | JArray JsonSchema
  | JString
  | JNumber
  | JBoolean

-- UTILITIES
verifyArity :: forall a b. Tuple (Maybe Int) (Maybe Int) -> (Array a -> b) -> Array a -> Either String b
verifyArity (Tuple (Just min) (Just max)) op xs =
  if (length xs < min) || (length xs > max)
  then Left ("invalid operator: expected between " <> (show min) <> " and " <> (show max) <> " operands")
  else pure $ op xs

verifyArity (Tuple Nothing (Just max)) op xs =
  if (length xs > max)
  then Left ("invalid operator: expected at most " <> (show max) <> " operand(s)")
  else pure $ op xs

verifyArity (Tuple (Just min) Nothing) op xs =
  if (length xs < min)
  then Left ("invalid operator: expected at least " <> (show min) <> " operand(s)")
  else pure $ op xs

verifyArity (Tuple Nothing Nothing) op xs =
  pure $ op xs

-- INSTANCE DECODEJSON
instance decodeJsonTerminal :: DecodeJson String => DecodeJson Terminal where
  decodeJson =
    let
        decoder (Just "field") (Just f) =
          Field <$> decodeJson f
        decoder (Just "constant") (Just c) | isNumber c =
          ConstantNumber <$> decodeJson c
        decoder (Just "constant") (Just c) | isBoolean c =
          ConstantBoolean <$> decodeJson c
        decoder (Just "constant") (Just c) | isString c =
          ConstantString <$> decodeJson c
        decoder _ _ =
          Left "unknown terminal operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonFilter :: DecodeJson String => DecodeJson Filter where
  decodeJson =
    let
        decoder (Just "eq") (Just fs) | isArray fs =
          decodeJson fs >>= verifyArity (Tuple (Just 2) Nothing) Eq
        decoder (Just "neq") (Just fs) | isArray fs =
          decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Neq
        decoder (Just "lt") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Lt
        decoder (Just "gt") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Gt
        decoder (Just "or") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 1) Nothing) Or
        decoder (Just "and") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 1) Nothing) And
        decoder _ _ =
          Left "unknown filter operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonReduce :: DecodeJson String => DecodeJson Reduce where
  decodeJson =
    let
        decoder (Just "avg") (Just f) =
          Avg <$> decodeJson f
        decoder (Just "max") (Just f) =
          Max <$> decodeJson f
        decoder (Just "min") (Just f) =
          Min <$> decodeJson f
        decoder (Just "sum") (Just f) =
          Sum <$> decodeJson f
        decoder _ _ =
          Left "unknown reduce operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonMap :: DecodeJson String => DecodeJson Map where
  decodeJson =
    let
        decoder (Just "abs") Nothing (Just term) =
          Abs <$> decodeJson term
        decoder (Just "add") Nothing (Just terms) | isArray terms =
          Add <$> decodeJson terms
        decoder (Just "ceil") Nothing (Just term) =
          Ceil <$> decodeJson term
        decoder (Just "constant") Nothing (Just c) | isNumber c =
          ConstantNumber >>> Project <$> decodeJson c
        decoder (Just "constant") Nothing (Just c) | isBoolean c =
          ConstantBoolean >>> Project <$> decodeJson c
        decoder (Just "constant") Nothing (Just c) | isString c =
          ConstantString >>> Project <$> decodeJson c
        decoder (Just "div") Nothing (Just terms) =
          decodeJson terms >>= verifyArity (Tuple (Just 2) (Just 2)) Div
        decoder (Just "field") Nothing (Just f) =
          Field >>> Project <$> decodeJson f
        decoder (Just "floor") Nothing (Just term) =
          Floor <$> decodeJson term
        decoder (Just "inject") (Just src) (Just op) =
          Inject <$> decodeJson src
                 <*> decodeJson op
        decoder (Just "mult") Nothing (Just terms) | isArray terms =
          Mult <$> decodeJson terms
        decoder _ _ _ =
          Left "unknown map operator"
    in
        decode3 "@" "[]" "=" decoder

instance decodeJsonStage :: (DecodeJson (StrMap Json), DecodeJson String)
  => DecodeJson Stage where
  decodeJson =
    let
        decoder (Just "map") (Just m) Nothing Nothing =
          Map <$> Right Nothing
              <*> traverse decodeJson m
        decoder (Just "map") (Just m) Nothing (Just f) =
          Map <$> decodeJson f
              <*> traverse decodeJson m

        decoder (Just "reduce") (Just m) Nothing Nothing =
          Reduce <$> Right Nothing
                 <*> traverse decodeJson m
        decoder (Just "reduce") (Just m) (Just i) Nothing =
          Reduce <$> decodeJson i
                 <*> traverse decodeJson m

        decoder _ _ _ _ =
          Left "unknown stage operator"
     in
        decode4 "@" "=" "#" "?" decoder

instance decodeJsonSchema :: DecodeJson JsonSchema where
  decodeJson =
    let
        decodeNull _ =
          Left "can't decode null to schema"
        decodeBoolean _ =
          Left "can't decode boolean to schema"
        decodeNumber _ =
          Left "can't decode number to schema"
        decodeString "string" =
          Right JString
        decodeString "number" =
          Right JNumber
        decodeString "boolean" =
          Right JBoolean
        decodeString s =
          Left ("can't decode type: invalid provided type: " <> s)
        decodeArray xs =
          if length xs /= 1
          then Left "can't decode array: exactly one element is expected"
          else case head xs of
            Nothing ->
              Left "can't decode array: exactly one element is expected"
            Just schema ->
              JArray <$> decodeJson schema
        decodeObject obj = JObject <$> traverse decodeJson obj
    in
        foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject

-- INSTANCE ENCODEJSON
instance encodeJsonTerminal :: EncodeJson (StrMap String) => EncodeJson Terminal where
  encodeJson term =
    let
        encode :: forall a. EncodeJson a => a -> Json
        encode x = encodeJson $ fromFoldable
          [ Tuple "@" (encodeJson "field")
          , Tuple "=" (encodeJson x)
          ]
    in case term of
        Field f -> encode f
        ConstantString c -> encode c
        ConstantBoolean c -> encode c
        ConstantNumber c -> encode c

instance encodeJsonFilter :: (EncodeJson (StrMap String), EncodeJson Terminal) => EncodeJson Filter where
  encodeJson (Eq t) =
    "@" := "eq" ~> "=" := t
  encodeJson (Neq t) =
    "@" := "neq" ~> "=" := t
  encodeJson (Lt t) =
    "@" := "lt" ~> "=" := t
  encodeJson (Gt t) =
    "@" := "gt" ~> "=" := t
  encodeJson (Or t) =
    "@" := "or" ~> "=" := t
  encodeJson (And t) =
    "@" := "and" ~> "=" := t

instance encodeJsonReduce :: (EncodeJson (StrMap String), EncodeJson Terminal) => EncodeJson Reduce where
  encodeJson (Avg t) =
    "@" := "avg" ~> "=" := t
  encodeJson (Min t) =
    "@" := "min" ~> "=" := t
  encodeJson (Max t) =
    "@" := "max" ~> "=" := t
  encodeJson (Sum t) =
    "@" := "sum" ~> "=" := t

instance encodeJsonMap :: (EncodeJson (StrMap String), EncodeJson Terminal)
  => EncodeJson Map where
  encodeJson (Abs t) =
    "@" := "abs" ~> "=" := t
  encodeJson (Add ts) =
    "@" := "add" ~> "=" := ts
  encodeJson (Ceil t) =
    "@" := "ceil" ~> "=" := t
  encodeJson (Div ts) =
    "@" := "div" ~> "=" := ts
  encodeJson (Floor t) =
    "@" := "floor" ~> "=" := t
  encodeJson (Inject s t) =
    "@" := "inject" ~> "[]" := s ~> "=" := t
  encodeJson (Mult ts) =
    "@" := "mult" ~> "=" := ts
  encodeJson (Project t) =
    "@" := "field" ~> "=" := t

instance encodeJsonStage :: (EncodeJson (StrMap String), EncodeJson Map)
  => EncodeJson Stage where
  encodeJson (Map filter m) =
    encodeJson $ fromFoldable $ concat
      [ [ "@" := "map", "=" := m ]
        , maybe [] (encodeJson >>> Tuple "?" >>> snoc []) filter
      ]
  encodeJson (Reduce index m) =
    encodeJson $ fromFoldable $ concat
      [ [ "@" := "reduce", "=" := m ]
        , maybe [] (encodeJson >>> Tuple "#" >>> snoc []) index
      ]

instance encodeJsonJsonSchema :: EncodeJson JsonSchema where
  encodeJson (JObject schema) =
    encodeJson $ map encodeJson schema
  encodeJson (JArray schema) =
    encodeJson [encodeJson schema]
  encodeJson JNumber =
    encodeJson "number"
  encodeJson JString =
    encodeJson "string"
  encodeJson JBoolean =
    encodeJson "boolean"

-- INSTANCE SHOW
instance showTerminal :: EncodeJson Terminal => Show Terminal where
  show = encodeJson >>> stringify

instance showFilter :: EncodeJson Terminal => Show Filter where
  show = encodeJson >>> stringify

instance showReduce :: EncodeJson Reduce => Show Reduce where
  show = encodeJson >>> stringify

instance showMap :: EncodeJson Map => Show Map where
  show = encodeJson >>> stringify

instance showStage :: EncodeJson Stage => Show Stage  where
  show = encodeJson >>> stringify

instance showJsonSchema :: EncodeJson JsonSchema => Show JsonSchema where
  show = encodeJson >>> stringify

module Ifrit.Core where

import Prelude

import Data.Argonaut.Core(Json, stringify, isArray, isString, isBoolean, isNumber, foldJson)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Array(concat, head, length, snoc)
import Data.Either(Either(..))
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap(StrMap, fromFoldable)
import Data.Traversable(traverse)
import Data.Tuple(Tuple(..))

import Ifrit.Decoder(decode2, decode3, decode4)

-- TYPES
data Terminal
  = Field String
  | ConstantString String
  | ConstantBoolean Boolean
  | ConstantNumber Number

data Filter
  = Eq (Array Terminal)
  | Neq (Array Terminal)
  | Lt (Array Terminal)
  | Gt (Array Terminal)
  | Or (Array Filter)
  | And (Array Filter)

data Map
  = Project Terminal
  | Inject Terminal Reduce
  | Add (Array Terminal)
  | Abs Terminal
  | Ceil Terminal
  | Div (Array Terminal)
  | Floor Terminal
  | Mult (Array Terminal)

data Reduce
  = Avg Terminal
  | Min Terminal
  | Max Terminal
  | Sum Terminal

data Stage
  = Map (Maybe Filter) (StrMap Map)
  | Reduce (Maybe Terminal) (StrMap Reduce)

type Pipeline =
  Array Stage

data JsonSchema
  = JObject (StrMap JsonSchema)
  | JArray JsonSchema
  | JString
  | JNumber
  | JBoolean

-- UTILITIES
verifyArity :: forall a b. Tuple (Maybe Int) (Maybe Int) -> (Array a -> b) -> Array a -> Either String b
verifyArity (Tuple (Just min) (Just max)) op xs =
  if (length xs < min) || (length xs > max)
  then Left ("invalid operator: expected between " <> (show min) <> " and " <> (show max) <> " operands")
  else pure $ op xs

verifyArity (Tuple Nothing (Just max)) op xs =
  if (length xs > max)
  then Left ("invalid operator: expected at most " <> (show max) <> " operand(s)")
  else pure $ op xs

verifyArity (Tuple (Just min) Nothing) op xs =
  if (length xs < min)
  then Left ("invalid operator: expected at least " <> (show min) <> " operand(s)")
  else pure $ op xs

verifyArity (Tuple Nothing Nothing) op xs =
  pure $ op xs

-- INSTANCE DECODEJSON
instance decodeJsonTerminal :: DecodeJson String => DecodeJson Terminal where
  decodeJson =
    let
        decoder (Just "field") (Just f) =
          Field <$> decodeJson f
        decoder (Just "constant") (Just c) | isNumber c =
          ConstantNumber <$> decodeJson c
        decoder (Just "constant") (Just c) | isBoolean c =
          ConstantBoolean <$> decodeJson c
        decoder (Just "constant") (Just c) | isString c =
          ConstantString <$> decodeJson c
        decoder _ _ =
          Left "unknown terminal operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonFilter :: DecodeJson String => DecodeJson Filter where
  decodeJson =
    let
        decoder (Just "eq") (Just fs) | isArray fs =
          decodeJson fs >>= verifyArity (Tuple (Just 2) Nothing) Eq
        decoder (Just "neq") (Just fs) | isArray fs =
          decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Neq
        decoder (Just "lt") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Lt
        decoder (Just "gt") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 2) (Just 2)) Gt
        decoder (Just "or") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 1) Nothing) Or
        decoder (Just "and") (Just fs) | isArray fs =
           decodeJson fs >>= verifyArity (Tuple (Just 1) Nothing) And
        decoder _ _ =
          Left "unknown filter operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonReduce :: DecodeJson String => DecodeJson Reduce where
  decodeJson =
    let
        decoder (Just "avg") (Just f) =
          Avg <$> decodeJson f
        decoder (Just "max") (Just f) =
          Max <$> decodeJson f
        decoder (Just "min") (Just f) =
          Min <$> decodeJson f
        decoder (Just "sum") (Just f) =
          Sum <$> decodeJson f
        decoder _ _ =
          Left "unknown reduce operator"
    in
        decode2 "@" "=" decoder

instance decodeJsonMap :: DecodeJson String => DecodeJson Map where
  decodeJson =
    let
        decoder (Just "abs") Nothing (Just term) =
          Abs <$> decodeJson term
        decoder (Just "add") Nothing (Just terms) | isArray terms =
          Add <$> decodeJson terms
        decoder (Just "ceil") Nothing (Just term) =
          Ceil <$> decodeJson term
        decoder (Just "constant") Nothing (Just c) | isNumber c =
          ConstantNumber >>> Project <$> decodeJson c
        decoder (Just "constant") Nothing (Just c) | isBoolean c =
          ConstantBoolean >>> Project <$> decodeJson c
        decoder (Just "constant") Nothing (Just c) | isString c =
          ConstantString >>> Project <$> decodeJson c
        decoder (Just "div") Nothing (Just terms) =
          decodeJson terms >>= verifyArity (Tuple (Just 2) (Just 2)) Div
        decoder (Just "field") Nothing (Just f) =
          Field >>> Project <$> decodeJson f
        decoder (Just "floor") Nothing (Just term) =
          Floor <$> decodeJson term
        decoder (Just "inject") (Just src) (Just op) =
          Inject <$> decodeJson src
                 <*> decodeJson op
        decoder (Just "mult") Nothing (Just terms) | isArray terms =
          Mult <$> decodeJson terms
        decoder _ _ _ =
          Left "unknown map operator"
    in
        decode3 "@" "[]" "=" decoder

instance decodeJsonStage :: (DecodeJson (StrMap Json), DecodeJson String)
  => DecodeJson Stage where
  decodeJson =
    let
        decoder (Just "map") (Just m) Nothing Nothing =
          Map <$> Right Nothing
              <*> traverse decodeJson m
        decoder (Just "map") (Just m) Nothing (Just f) =
          Map <$> decodeJson f
              <*> traverse decodeJson m

        decoder (Just "reduce") (Just m) Nothing Nothing =
          Reduce <$> Right Nothing
                 <*> traverse decodeJson m
        decoder (Just "reduce") (Just m) (Just i) Nothing =
          Reduce <$> decodeJson i
                 <*> traverse decodeJson m

        decoder _ _ _ _ =
          Left "unknown stage operator"
     in
        decode4 "@" "=" "#" "?" decoder

instance decodeJsonSchema :: DecodeJson JsonSchema where
  decodeJson =
    let
        decodeNull _ =
          Left "can't decode null to schema"
        decodeBoolean _ =
          Left "can't decode boolean to schema"
        decodeNumber _ =
          Left "can't decode number to schema"
        decodeString "string" =
          Right JString
        decodeString "number" =
          Right JNumber
        decodeString "boolean" =
          Right JBoolean
        decodeString s =
          Left ("can't decode type: invalid provided type: " <> s)
        decodeArray xs =
          if length xs /= 1
          then Left "can't decode array: exactly one element is expected"
          else case head xs of
            Nothing ->
              Left "can't decode array: exactly one element is expected"
            Just schema ->
              JArray <$> decodeJson schema
        decodeObject obj = JObject <$> traverse decodeJson obj
    in
        foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject

-- INSTANCE ENCODEJSON
instance encodeJsonTerminal :: EncodeJson (StrMap String) => EncodeJson Terminal where
  encodeJson term =
    let
        encode :: forall a. EncodeJson a => a -> Json
        encode x = encodeJson $ fromFoldable
          [ Tuple "@" (encodeJson "field")
          , Tuple "=" (encodeJson x)
          ]
    in case term of
        Field f -> encode f
        ConstantString c -> encode c
        ConstantBoolean c -> encode c
        ConstantNumber c -> encode c

instance encodeJsonFilter :: (EncodeJson (StrMap String), EncodeJson Terminal) => EncodeJson Filter where
  encodeJson (Eq t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "eq")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Neq t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "neq")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Lt t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "lt")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Gt t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "gt")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Or t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "or")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (And t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "and")
      , Tuple "=" (encodeJson t)
      ]

instance encodeJsonReduce :: (EncodeJson (StrMap String), EncodeJson Terminal) => EncodeJson Reduce where
  encodeJson (Avg t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "avg")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Min t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "min")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Max t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "max")
      , Tuple "=" (encodeJson t)
      ]
  encodeJson (Sum t) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "sum")
      , Tuple "=" (encodeJson t)
      ]

instance encodeJsonMap :: (EncodeJson (StrMap String), EncodeJson Terminal)
  => EncodeJson Map where
  encodeJson (Abs term) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "abs")
      , Tuple "=" (encodeJson term)
      ]
  encodeJson (Add terms) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "add")
      , Tuple "=" (encodeJson terms)
      ]
  encodeJson (Ceil term) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "ceil")
      , Tuple "=" (encodeJson term)
      ]
  encodeJson (Div terms) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "div")
      , Tuple "=" (encodeJson terms)
      ]
  encodeJson (Floor term) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "floor")
      , Tuple "=" (encodeJson term)
      ]
  encodeJson (Inject src target) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "inject")
      , Tuple "[]"(encodeJson src)
      , Tuple "=" (encodeJson target)
      ]
  encodeJson (Mult terms) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "mult")
      , Tuple "=" (encodeJson terms)
      ]
  encodeJson (Project term) =
    encodeJson $ fromFoldable
      [ Tuple "@" (encodeJson "field")
      , Tuple "=" (encodeJson term)
      ]

instance encodeJsonStage :: (EncodeJson (StrMap String), EncodeJson Map)
  => EncodeJson Stage where
  encodeJson (Map filter m) =
    encodeJson $ fromFoldable $ concat
      [ [ Tuple "@" (encodeJson "map")
        , Tuple "=" (encodeJson m)
        ]
        , maybe [] (encodeJson >>> Tuple "?" >>> snoc []) filter
      ]
  encodeJson (Reduce index m) =
    encodeJson $ fromFoldable $ concat
      [ [ Tuple "@" (encodeJson "reduce")
        , Tuple "=" (encodeJson m)
        ]
        , maybe [] (encodeJson >>> Tuple "#" >>> snoc []) index
      ]

instance encodeJsonJsonSchema :: EncodeJson JsonSchema where
  encodeJson (JObject schema) =
    encodeJson $ map encodeJson schema
  encodeJson (JArray schema) =
    encodeJson [encodeJson schema]
  encodeJson JNumber =
    encodeJson "number"
  encodeJson JString =
    encodeJson "string"
  encodeJson JBoolean =
    encodeJson "boolean"

-- INSTANCE SHOW
instance showTerminal :: EncodeJson Terminal => Show Terminal where
  show = encodeJson >>> stringify

instance showFilter :: EncodeJson Terminal => Show Filter where
  show = encodeJson >>> stringify

instance showReduce :: EncodeJson Reduce => Show Reduce where
  show = encodeJson >>> stringify

instance showMap :: EncodeJson Map => Show Map where
  show = encodeJson >>> stringify

instance showStage :: EncodeJson Stage => Show Stage  where
  show = encodeJson >>> stringify

instance showJsonSchema :: EncodeJson JsonSchema => Show JsonSchema where
  show = encodeJson >>> stringify


Change zero-score logic

Change zero-score logic

-- | 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.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import 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.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type ValueMapping = Tuple D.Argument D.Value
type Parser a = P.ParserT (List Token) (Reader D.Env) 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: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "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 (D.StringValue v)
    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 tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

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

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust 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) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue 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) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue 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) && (not takesArg) && (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 _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = 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 <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- | Fold over a list of parsers, applying each in turn onto the result of the
-- | previous, keeping both errors and results. Each application of a branches
-- | parser must set out from the same parser state.

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.

genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
  env :: D.Env <- ask
  let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> genBranchParser x
      rs = runReader (collect s ps) env

  -- Weed out successful parses that have a zero-scores, from successful
  -- parses that have a non-zero score. Zero-scores are treated as errors
  -- due to ambiguity if no none-zero score was attained. Should there be
  -- only a single zero-score, however, it can walk away the victor.
  -- XXX: Should the ambiguity rules be extended for any score? I.e. if
  --      there's a total tie across all scores.
  (Tuple zs as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult <<< _.result)
             $ mrights rs

  return $ maybe'
    (\_ ->
      maybe'
        (\_ ->
          -- XXX: The following needs review. Is this safe? correct?
          let h = LU.head zs
            in h { result = Right <<< _.result <<< unScoredResult $ h.result }
        )
        (\e -> e { result = Left e.result })
        (head $ mlefts rs)
    )
    (\r -> r { result = Right <<< _.result <<< unScoredResult $ r.result })
    (maximumBy (compare `on` _.result) as)
  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o ->
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   e
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   r
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

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

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

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

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

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

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

        draw _ _ = return mempty

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

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

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

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

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

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

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

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

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

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) 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)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

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

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

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

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

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

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import 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.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type ValueMapping = Tuple D.Argument D.Value
type Parser a = P.ParserT (List Token) (Reader D.Env) 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: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "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 (D.StringValue v)
    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 tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

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

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust 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) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue 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) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue 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) && (not takesArg) && (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 _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = 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 <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- | Fold over a list of parsers, applying each in turn onto the result of the
-- | previous, keeping both errors and results. Each application of a branches
-- | parser must set out from the same parser state.

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.

genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
  env :: D.Env <- ask
  let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> genBranchParser x
      rs = runReader (collect s ps) env

  -- Weed out successful parses that have a zero-scores, from successful
  -- parses that have a non-zero score. Zero-scores are treated as errors
  -- due to ambiguity if no none-zero score was attained. Should there be
  -- only a single zero-score, however, it can walk away the victor.
  -- XXX: Should the ambiguity rules be extended for any score? I.e. if
  --      there's a total tie across all scores.
  (Tuple zs as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult <<< _.result)
             $ mrights rs

  return $ maybe'
    (\_ ->
      maybe'
        (\_ ->
          -- XXX: The following needs review. The idea is that if there
          --      was not a single match with a score above 0, but there
          --      is exactly a single match with a score of 0, just use it.
          if length xs == 1
            then
              let h = LU.head zs
               in h { result = Right <<< _.result <<< unScoredResult $ h.result }
            else P.parseFailed i pos "Ambigious match"
        )
        (\e -> e { result = Left e.result })
        (head $ mlefts rs)
    )
    (\r -> r { result = Right <<< _.result <<< unScoredResult $ r.result })
    (maximumBy (compare `on` _.result) as)
  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o ->
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   e
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   r
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

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

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

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

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

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

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

        draw _ _ = return mempty

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

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

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

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

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

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

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

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

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

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) 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)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

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

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

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

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


Refactoring

Refactoring

module Util.Parse where

import Control.Alt ((<|>))
import Data.Array (fromFoldable)
import Data.Char (toLower, toCharCode)
import Data.List (List)
import Data.Either (either)
import Data.String (fromCharArray)
import Data.Maybe (Maybe(..))
import Color (Color, fromHexString)
import Text.Parsing.StringParser (Parser, try, fail, runParser)
import Text.Parsing.StringParser.String (satisfy, anyChar, char, whiteSpace, skipSpaces)
import Text.Parsing.StringParser.Combinators (optional, sepEndBy, many, manyTill)
import Prelude

isHex :: Char -> Boolean
isHex c = isDigit || isABCDEF where
  isDigit  = code >= 48 && code <= 57  {- 0, 9 -}
  isABCDEF = code >= 97 && code <= 102 {- a, f -}
  code     = (toCharCode <<< toLower) c

parseHex3 :: Parser Color
parseHex3 = do
  _ <- optional (char '#')
  r <- satisfy isHex
  g <- satisfy isHex
  b <- satisfy isHex
  case (fromHexString ("#" <> fromCharArray [r, g, b])) of
    Nothing -> (fail "Could not parse HEX3")
    Just c  -> pure c

parseHex6 :: Parser Color
parseHex6 = do
  _  <- optional (char '#')
  r  <- satisfy isHex
  r' <- satisfy isHex
  g  <- satisfy isHex
  g' <- satisfy isHex
  b  <- satisfy isHex
  b' <- satisfy isHex
  case (fromHexString ("#" <> fromCharArray [r, r', g, g', b, b'])) of
    Nothing -> (fail "Could not parse HEX6")
    Just c  -> pure c

parseHex :: Parser Color
parseHex = try parseHex6 <|> parseHex3

parseColor :: Parser (List Color)
parseColor = skipNonHex *> sepEndBy parseHex nonHex

nonHex :: Parser (List Char)
nonHex = many (satisfy (not <<< isHex))

skipNonHex :: Parser Unit
skipNonHex = void nonHex

parse' :: Parser (List Color) -> String -> Array Color
parse' p s = either
  (const [])
  fromFoldable
  (runParser p s)

parse :: String -> Array Color
parse = parse' parseColor

module Util.Parse where

import Control.Alt ((<|>))
import Data.Array (fromFoldable)
import Data.Char (toLower, toCharCode)
import Data.List (List)
import Data.Either (either)
import Data.String (fromCharArray)
import Data.Maybe (Maybe(..))
import Color (Color, fromHexString)
import Text.Parsing.StringParser (Parser, try, fail, runParser)
import Text.Parsing.StringParser.String (satisfy, char, whiteSpace, skipSpaces)
import Text.Parsing.StringParser.Combinators (optional, sepEndBy)
import Prelude

isHex :: Char -> Boolean
isHex c = isDigit || isABCDEF where
  isDigit  = code >= 48 && code <= 57  {- 0, 9 -}
  isABCDEF = code >= 97 && code <= 102 {- a, f -}
  code     = (toCharCode <<< toLower) c

parseHex3 :: Parser Color
parseHex3 = do
  _ <- optional (char '#')
  r <- satisfy isHex
  g <- satisfy isHex
  b <- satisfy isHex
  case (fromHexString ("#" <> fromCharArray [r, g, b])) of
    Nothing -> (fail "Could not parse HEX3")
    Just c  -> pure c

parseHex6 :: Parser Color
parseHex6 = do
  _  <- optional (char '#')
  r  <- satisfy isHex
  r' <- satisfy isHex
  g  <- satisfy isHex
  g' <- satisfy isHex
  b  <- satisfy isHex
  b' <- satisfy isHex
  case (fromHexString ("#" <> fromCharArray [r, r', g, g', b, b'])) of
    Nothing -> (fail "Could not parse HEX6")
    Just c  -> pure c

parseHex :: Parser Color
parseHex = try parseHex6 <|> try parseHex3

-- Try looking at the implementation details and work out a way to ignore
-- non-hex characters...

p :: Parser (List Color)
p = do
  skipSpaces
  c <- sepEndBy parseHex whiteSpace
  pure c

parse :: String -> Array Color
parse s = either
  (const [])
  fromFoldable
  (runParser p s)


Define some types for third try

Define some types for third try

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module ThirdTab
  ( class ColT
  ) where

import Data.List

class ColT a

type Cells a = ColT a => List a

newtype Col a = Col { id :: Int, name :: String }

newtype ThirdTab colTypes = ThirdTab
  { cols :: List colTypes
  , rows :: List (Cells colTypes)
  }

empty :: forall a. ColT a => ThirdTab a
empty = ThirdTab
  { cols : Nil
  , rows : Nil
  }

addColumn :: forall a. ColT a => Int -> String -> ThirdTab a -> ThirdTab _
addColumn id name (ThirdTab table) = ThirdTab { cols: table.cols, rows: Nil }

module ThirdTab
  ( class ColT
  ) where

import Data.List

class ColT a

type Cells a = List a

newtype ThirdTab colTypes = ThirdTab
  { cols :: List colTypes
  , rows :: List (Cells colTypes)
  }

empty :: forall a. ColT a => ThirdTab a
empty = ThirdTab
  { cols : Nil
  , rows : Nil
  }

addColumn :: forall a. ColT a => Int -> String -> ThirdTab a -> ThirdTab a
addColumn id name (ThirdTab table) = ThirdTab { cols: table.cols, rows: table.rows }


Add tests for Ord util functions

Add tests for Ord util functions

module Test.Main where

import Prelude

type AlmostEff = Unit -> Unit

main :: AlmostEff
main = do
    testNumberShow show
    testOrderings
    testOrdUtils
    testIntDegree

foreign import testNumberShow :: (Number -> String) -> AlmostEff
foreign import throwErr :: String -> AlmostEff

assert :: String -> Boolean -> AlmostEff
assert msg condition = if condition then const unit else throwErr msg

testOrd :: forall a. Ord a => Show a => a -> a -> Ordering -> AlmostEff
testOrd x y ord =
    assert
        ("(compare " <> show x <> " " <> show y <> " ) is not equal to " <> show ord)
        $ (compare x y) == ord

nan :: Number
nan = 0.0/0.0

-- Unfortunately, NaN inhabits our Int
intNan :: Int
intNan = mod 1 0

plusInfinity :: Number
plusInfinity = 1.0/0.0

minusInfinity :: Number
minusInfinity = -1.0/0.0

testOrderings :: AlmostEff
testOrderings = do
    assert "NaN shouldn't be equal to itself" $ nan /= nan
    assert "NaN shouldn't be equal to itself" $ (compare nan nan) /= EQ
    testOrd 1.0    2.0 LT
    testOrd 2.0    1.0 GT
    testOrd 1.0    (-2.0) GT
    testOrd (-2.0) 1.0 LT
    testOrd minusInfinity plusInfinity LT
    testOrd minusInfinity 0.0 LT
    testOrd plusInfinity  0.0 GT
    testOrd plusInfinity  minusInfinity GT
    testOrd 1.0 nan GT
    testOrd nan 1.0 GT
    testOrd nan plusInfinity GT
    testOrd plusInfinity nan GT
    assert "1 > NaN should be false" $ (1.0 > nan) == false
    assert "1 < NaN should be false" $ (1.0 < nan) == false
    assert "NaN > 1 should be false" $ (nan > 1.0) == false
    assert "NaN < 1 should be false" $ (nan < 1.0) == false
    assert "NaN == 1 should be false" $ nan /= 1.0
    testOrd intNan 2147483647 GT
    testOrd 'a' 'b' LT
    testOrd 'b' 'A' GT
    testOrd "10" "0" GT
    testOrd "10" "2" LT
    testOrd true  true EQ
    testOrd false false EQ
    testOrd false true LT
    testOrd true  false GT
    testOrd ([] :: Array Int) [] EQ
    testOrd [1, 0]  [1] GT
    testOrd [1]     [1, 0] LT
    testOrd [1, 1]  [1, 0] GT
    testOrd [1, -1] [1, 0] LT

testOrdUtils :: AlmostEff
testOrdUtils = do
  assert "-5 clamped between 0 and 10 should be 0" $ clamp 0 10 (-5) == 0
  assert "5 clamped between 0 and 10 should be 5" $ clamp 0 10 5 == 5
  assert "15 clamped between 0 and 10 should be 10" $ clamp 0 10 15 == 10
  assert "-5 should not be between 0 and 10" $ between 0 10 (-5) == false
  assert "5 should be between 0 and 10" $ between 0 10 5 == true
  assert "15 should not be between 0 10" $ between 0 10 15 == false

testIntDegree :: AlmostEff
testIntDegree = do
    let bot = bottom :: Int
    assert "degree returns absolute integers" $ degree (-4) == 4
    assert "degree returns absolute integers" $ degree 4 == 4
    assert "degree returns absolute integers" $ degree bot >= 0
    assert "degree does not return out-of-bounds integers" $ degree bot <= top

module Test.Main where

import Prelude

type AlmostEff = Unit -> Unit

main :: AlmostEff
main = do
    testNumberShow show
    testOrderings
    testIntDegree

foreign import testNumberShow :: (Number -> String) -> AlmostEff
foreign import throwErr :: String -> AlmostEff

assert :: String -> Boolean -> AlmostEff
assert msg condition = if condition then const unit else throwErr msg

testOrd :: forall a. Ord a => Show a => a -> a -> Ordering -> AlmostEff
testOrd x y ord =
    assert
        ("(compare " <> show x <> " " <> show y <> " ) is not equal to " <> show ord)
        $ (compare x y) == ord

nan :: Number
nan = 0.0/0.0

-- Unfortunately, NaN inhabits our Int
intNan :: Int
intNan = mod 1 0

plusInfinity :: Number
plusInfinity = 1.0/0.0

minusInfinity :: Number
minusInfinity = -1.0/0.0

testOrderings :: AlmostEff
testOrderings = do
    assert "NaN shouldn't be equal to itself" $ nan /= nan
    assert "NaN shouldn't be equal to itself" $ (compare nan nan) /= EQ
    testOrd 1.0    2.0 LT
    testOrd 2.0    1.0 GT
    testOrd 1.0    (-2.0) GT
    testOrd (-2.0) 1.0 LT
    testOrd minusInfinity plusInfinity LT
    testOrd minusInfinity 0.0 LT
    testOrd plusInfinity  0.0 GT
    testOrd plusInfinity  minusInfinity GT
    testOrd 1.0 nan GT
    testOrd nan 1.0 GT
    testOrd nan plusInfinity GT
    testOrd plusInfinity nan GT
    assert "1 > NaN should be false" $ (1.0 > nan) == false
    assert "1 < NaN should be false" $ (1.0 < nan) == false
    assert "NaN > 1 should be false" $ (nan > 1.0) == false
    assert "NaN < 1 should be false" $ (nan < 1.0) == false
    assert "NaN == 1 should be false" $ nan /= 1.0
    testOrd intNan 2147483647 GT
    testOrd 'a' 'b' LT
    testOrd 'b' 'A' GT
    testOrd "10" "0" GT
    testOrd "10" "2" LT
    testOrd true  true EQ
    testOrd false false EQ
    testOrd false true LT
    testOrd true  false GT
    testOrd ([] :: Array Int) [] EQ
    testOrd [1, 0]  [1] GT
    testOrd [1]     [1, 0] LT
    testOrd [1, 1]  [1, 0] GT
    testOrd [1, -1] [1, 0] LT

testIntDegree :: AlmostEff
testIntDegree = do
    let bot = bottom :: Int
    assert "degree returns absolute integers" $ degree (-4) == 4
    assert "degree returns absolute integers" $ degree 4 == 4
    assert "degree returns absolute integers" $ degree bot >= 0
    assert "degree does not return out-of-bounds integers" $ degree bot <= top