Dropped unneded foreign import

Dropped unneded foreign import

-- TODO: ON ERROR: RECONNECT!
module Servant.Subscriber (
    makeSubscriber
  , subscribe
  , unsubscribe
  , close
  , Subscriber
  , NotifyEvent (..)
  , SubscriberEff
  ) where

import Prelude
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Var as Var
import Data.List as List
import Data.StrMap as StrMap
import Servant.Subscriber.Response as Resp
import WebSocket as WS
import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, catchException)
import Control.Monad.Eff.Ref (Ref, REF, modifyRef, writeRef, newRef, readRef)
import DOM.Event.Types (Event)
import DOM.Websocket.Event.Types (CloseEvent, MessageEvent)
import DOM.Websocket.Event.CloseEvent as CloseEvent
import DOM.HTML.Event.ErrorEvent as ErrorEvent
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Printer (printJson)
import Data.Either (Either(Right, Left))
import Data.Foldable (sequence_, intercalate, foldl)
import Data.Generic (class Generic)
import Data.Lens (view, prism, (.~), _Just, _2)
import Data.Lens.At (at)
import Data.Lens.Lens (lens)
import Data.Lens.Types (PrismP, LensP)
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (StrMap)
import Data.Tuple (fst)
import Servant.Subscriber.Request (HttpRequest(HttpRequest), Request(Subscribe, Unsubscribe))
import Servant.Subscriber.Response (Response)
import Servant.Subscriber.Types (Path(Path))
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (ReadyState(Open), Code(Code), WEBSOCKET, Connection(..), newWebSocket, Message(..))

type SubscriberEff eff = Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff)

type SubscriberImpl = {
    subscriptions :: Ref Subscriptions
  , url :: WS.URL
  , notify :: forall eff. NotifyEvent -> SubscriberEff eff Unit
  , connection :: Ref (Maybe Connection)
  }

newtype Subscriber = Subscriber SubscriberImpl

data NotifyEvent = NotifyEvent Response
    | ParseError String -- We could not parse the server's response
    | WebSocketError String
    | WebSocketClosed String

derive instance genericNotifyEvent :: Generic NotifyEvent

type Subscriptions = StrMap Subscription

type Subscription = {
    req :: Request
  , state :: SubscriptionState
  }

req :: forall r a. LensP ({ req :: a | r}) a
req = lens _.req (\r -> r { req = _ })

state :: forall r a. LensP ({ state :: a | r}) a
state = lens _.state (\r -> r { state = _ })

data SubscriptionState = Ordered | Sent | Confirmed

derive instance eqSubscriptionState :: Eq SubscriptionState

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

makeSubscriber :: forall eff. String -> (NotifyEvent -> SubscriberEff eff Unit) -> SubscriberEff eff Subscriber
makeSubscriber url h = do
      connRef <- newRef Nothing
      subscriptions <- Ref.newRef StrMap.empty
      pure $ Subscriber {
                    subscriptions : subscriptions
                  , url : WS.URL url
                  , notify : coerceEffects <<< h
                  , connection : connRef
                  }

-- | Drop all subscriptions and close connection.
close :: forall eff. Subscriber -> SubscriberEff eff Unit
close (Subscriber impl) = do
      writeRef impl.subscriptions StrMap.empty
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> pure unit
        Just (Connection conn) -> conn.close' (Code 1000) Nothing

subscribe :: forall eff. HttpRequest -> Subscriber -> SubscriberEff eff Unit
subscribe request (Subscriber impl) = do
      modifyRef impl.subscriptions $ at (reqToKey request) .~ Just { state : Ordered, req : Subscribe request }
      tryRealize impl

unsubscribe :: forall eff. Path -> Subscriber -> SubscriberEff eff Unit
unsubscribe p (Subscriber impl) = do
      mc <- readRef impl.connection
      case mc of
        Nothing -> modifyRef impl.subscriptions $ StrMap.delete (pathToKey p)
        Just c -> do
          modifyRef impl.subscriptions $ at (pathToKey p) <<< _Just .~ { req : Unsubscribe p, state : Ordered }
          tryRealize impl

tryRealize :: forall eff. SubscriberImpl -> SubscriberEff eff Unit
tryRealize impl = do
      mc <- readRef impl.connection
      case mc of
          Nothing -> makeConnection impl
          Just c'@(Connection c) -> do
            rdy <- Var.get c.readyState
            case rdy of
              Open -> realize c' impl
              _    -> pure unit

-- | Takes care of actually subscribing stuff.
realize :: forall eff. Connection -> SubscriberImpl -> SubscriberEff eff Unit
realize (Connection conn) impl = do
      ordered <- List.filter ((_ == Ordered) <<< _.state) <<< StrMap.values <$> Ref.readRef impl.subscriptions
      let mkMsg = Message <<< printJson <<< encodeJson
      let msgs = map (mkMsg <<< _.req) ordered
      sequence_ $ map (coerceEffects <<< conn.send) msgs
    --  modifyRef impl.subscriptions $ over (mapped <<< state <<< match Requested) (const Sent) -- Does not work currently.
    --  modifyRef impl.subscriptions $ traverse <<< state <<< filtered (_ == Ordered) .~ Sent -- Does not work currently
      modifyRef impl.subscriptions $ map (\sub -> if sub.state == Ordered then sub { state = Sent } else sub)

initConnection :: forall eff. SubscriberImpl -> SubscriberEff eff Unit
initConnection impl = do
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> makeConnection impl
        Just _ -> pure unit

makeConnection :: forall eff. SubscriberImpl -> SubscriberEff eff Unit
makeConnection impl = do
      Connection conn <- newWebSocket impl.url []
      Var.set conn.onclose   $ closeHandler impl
      Var.set conn.onmessage $ messageHandler impl
      Var.set conn.onerror   $ errorHandler impl
      Var.set conn.onopen    $ openHandler (Connection conn) impl
      writeRef impl.connection $ Just (Connection conn)

openHandler :: forall eff. Connection -> SubscriberImpl -> Event -> SubscriberEff eff Unit
openHandler conn impl _ = realize conn impl

closeHandler :: forall eff. SubscriberImpl -> CloseEvent -> SubscriberEff eff Unit
closeHandler impl ev = do
      writeRef impl.connection Nothing
      subs <- readRef impl.subscriptions
      if StrMap.isEmpty subs
        then pure unit
        else do
          modifyRef impl.subscriptions $ updateSubscriptions
          makeConnection impl
      impl.notify $ WebSocketClosed ("code: " <> (show <<< CloseEvent.code) ev <> ", reason: " <> CloseEvent.reason ev)
  where
    isUnsubscribe :: Request -> Boolean
    isUnsubscribe (Unsubscribe _) = true
    isUnsubscribe _ = false

    updateSubscriptions :: Subscriptions -> Subscriptions
    updateSubscriptions subs = let
          forRemoval = map fst <<< List.filter (isUnsubscribe <<< view (_2 <<< req)) <<< StrMap.toList $ subs
          cleanedSubs = foldl (flip StrMap.delete) subs forRemoval
        in
          map ( _ { state = Ordered } ) cleanedSubs

errorHandler :: forall eff. SubscriberImpl -> Event -> SubscriberEff eff Unit
errorHandler impl ev = do
      impl.notify $ WebSocketError ((ErrorEvent.message <<< unsafeCoerce) ev)
      tryRealize impl -- Something went wrong - retry. (TODO: Probably better with some timeout!)

messageHandler :: forall eff. SubscriberImpl -> MessageEvent -> SubscriberEff eff Unit
messageHandler impl msgEvent =  do
      let msg = WS.runMessage <<< WS.runMessageEvent $ msgEvent
      let eDecoded = decodeJson <=< jsonParser $ msg
      case eDecoded of
        Left err -> impl.notify $ ParseError (err <> ", input: '" <> msg <> "'")
        Right resp -> do
            modifyRef impl.subscriptions $ case resp of
                Resp.Subscribed path   -> at (pathToKey path) <<< _Just <<< state .~ Confirmed
                Resp.Deleted path      -> at (pathToKey path) .~ (Nothing :: Maybe Subscription)
                Resp.Unsubscribed path -> at (pathToKey path) .~ (Nothing :: Maybe Subscription)
                Resp.Modified _ _      -> id
                Resp.RequestError _    -> id
            impl.notify $ NotifyEvent resp

reqToPath :: HttpRequest -> Path
reqToPath (HttpRequest r) = r.httpPath

reqToKey :: HttpRequest -> String
reqToKey = pathToKey <<< reqToPath

pathToKey :: Path -> String
pathToKey (Path p) = intercalate "/" p

-- | Prism for only setting a value if it is equal to a.
match :: forall a. Eq a => a -> PrismP a a
match a = prism id $ \b -> if a == b then Right a else Left b

try :: forall a eff. Eff (err :: EXCEPTION | eff) a -> Eff eff (Either Error a)
try action = catchException (pure <<< Left) (map Right action)

foreign import jsString :: forall a. a -> String


Fork queued message handling

Fork queued message handling

module Halogen.Aff.Driver
  ( Driver
  , RenderSpec
  , runUI
  , module Exports
  ) where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff, forkAff, forkAll)
import Control.Monad.Aff.AVar (AVAR, AVar, putVar, takeVar, modifyVar)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (unwrap)
import Data.Traversable (traverse_, for_, sequence)
import Data.Tuple (Tuple(..))

import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

-- | Type alias for driver functions generated by `runUI` - a driver takes an
-- | input of the query algebra (`f`) and returns an `Aff` that returns when
-- | query has been fulfilled.
type Driver f eff = f ~> Aff (HalogenEffects eff)

type DSL s f m eff p o = HalogenF s f m p o (Aff (HalogenEffects eff))

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  sequence $ L.reverse initializers
  forkAll finalizers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

-- | This function is the main entry point for a Halogen based UI, taking a root
-- | component, initial state, and HTML element to attach the rendered component
-- | to.
-- |
-- | The returned "driver" function can be used to send actions and requests
-- | into the component hierarchy, allowing the outside world to communicate
-- | with the UI.
runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (Driver f eff)
runUI renderSpec component = _.driver <$> do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs ->
    runComponent (const (pure unit)) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        -- The record here is a hack around a skolem escape issue. If the typing
        -- rules for records change so this no longer works it may also be
        -- fixable with copious type annotations.
        pure { driver: evalF st.selfRef }

  where

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \component -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState component componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    addInitializer lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> DSL s f' g eff p o'
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f next -> do
      modifyVar (\(DriverState st) -> DriverState (st { state = f st.state })) ref
      handleLifecycle \lchs -> render lchs ref
      pure next
    Subscribe es next -> do
      let consumer = forever (lift <<< evalF ref =<< CR.await)
      forkAff $ CR.runProcess (unwrap es $$ consumer)
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- takeVar ref
      case pendingOut of
        Nothing -> do
          putVar ref (DriverState ds)
          handler o
        Just p ->
          putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- takeVar var
    case pendingIn of
      Nothing -> do
        putVar var (DriverState ds)
        handler message
      Just p ->
        putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  handlePending
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- takeVar ref
    putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (forkAll <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- takeVar ref
    putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (forkAll <<< map handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AVar a -> Aff (avar :: AVAR | eff) a
peekVar v = do
  a <- takeVar v
  putVar v a
  pure a

module Halogen.Aff.Driver
  ( Driver
  , RenderSpec
  , runUI
  , module Exports
  ) where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine (($$))
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff, forkAff, forkAll)
import Control.Monad.Aff.AVar (AVAR, AVar, putVar, takeVar, modifyVar)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (unwrap)
import Data.Traversable (traverse_, for_, sequence)
import Data.Tuple (Tuple(..))

import Halogen.Aff.Driver.State (ComponentType(..), DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.Effects (HalogenEffects)
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))

import Halogen.Aff.Driver.State (ComponentType(..)) as Exports

-- | Type alias for driver functions generated by `runUI` - a driver takes an
-- | input of the query algebra (`f`) and returns an `Aff` that returns when
-- | query has been fulfilled.
type Driver f eff = f ~> Aff (HalogenEffects eff)

type DSL s f m eff p o = HalogenF s f m p o (Aff (HalogenEffects eff))

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

handleLifecycle
  :: forall eff r
   . (Ref (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- liftEff $ newRef { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- liftEff $ readRef lchs
  sequence $ L.reverse initializers
  forkAll finalizers
  pure result

type RenderSpec h r eff =
  { render
      :: forall f g p
       . (forall x. f x -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit) -> Aff (HalogenEffects eff) r)
      -> h (ComponentSlot h g (Aff (HalogenEffects eff)) p (f Unit)) (f Unit)
      -> ComponentType
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  , renderChild
      :: Int
      -> Maybe r
      -> Aff (HalogenEffects eff) r
  }

-- | This function is the main entry point for a Halogen based UI, taking a root
-- | component, initial state, and HTML element to attach the rendered component
-- | to.
-- |
-- | The returned "driver" function can be used to send actions and requests
-- | into the component hierarchy, allowing the outside world to communicate
-- | with the UI.
runUI
  :: forall h r f o eff
   . RenderSpec h r eff
  -> Component h f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (Driver f eff)
runUI renderSpec component = _.driver <$> do
  fresh <- liftEff $ newRef 0
  handleLifecycle \lchs ->
    runComponent (const (pure unit)) fresh lchs Root component
      >>= peekVar
      >>= unDriverStateX \st ->
        -- The record here is a hack around a skolem escape issue. If the typing
        -- rules for records change so this no longer works it may also be
        -- fixable with copious type annotations.
        pure { driver: evalF st.selfRef }

  where

  runComponent
    :: forall f' o'
     . (o' -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> Ref (LifecycleHandlers eff)
    -> ComponentType
    -> Component h f' o' (Aff (HalogenEffects eff))
    -> Aff (HalogenEffects eff) (AVar (DriverStateX h r f' eff))
  runComponent handler fresh lchs componentType = unComponent \component -> do
    keyId <- liftEff $ readRef fresh
    liftEff $ modifyRef fresh (_ + 1)
    var <- initDriverState component componentType handler keyId fresh
    unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
    addInitializer lchs =<< peekVar var
    pure var

  eval
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> DSL s f' g eff p o'
    ~> Aff (HalogenEffects eff)
  eval ref = case _ of
    GetState k -> do
      DriverState { state } <- peekVar ref
      pure (k state)
    ModifyState f next -> do
      modifyVar (\(DriverState st) -> DriverState (st { state = f st.state })) ref
      handleLifecycle \lchs -> render lchs ref
      pure next
    Subscribe es next -> do
      let consumer = forever (lift <<< evalF ref =<< CR.await)
      forkAff $ CR.runProcess (unwrap es $$ consumer)
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- peekVar ref
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { mkOrdBox, children } <- peekVar ref
      pure $ k $ M.member (mkOrdBox p) children
    ChildQuery cq ->
      evalChildQuery ref cq
    Raise o a -> do
      DriverState (ds@{ handler, pendingOut }) <- takeVar ref
      case pendingOut of
        Nothing -> do
          putVar ref (DriverState ds)
          handler o
        Just p ->
          putVar ref (DriverState ds { pendingOut = Just (o : p) })
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

  evalChildQuery
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> ChildQuery g (Aff (HalogenEffects eff)) p
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref = unChildQuery \p k -> do
    DriverState st <- peekVar ref
    case M.lookup (st.mkOrdBox p) st.children of
      Just var -> do
        dsx <- peekVar var
        k (unDriverStateX (\ds -> evalF ds.selfRef) dsx)
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- peekVar ref
    case st.component.eval q of
      HalogenM fx -> foldFree (eval ref) fx

  evalM
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> HalogenM s f' g p o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (eval ref) q

  render
    :: forall s f' g p o'
     . Ref (LifecycleHandlers eff)
    -> AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  render lchs var = takeVar var >>= \(DriverState ds) -> do
    childrenVar <- liftEff $ newRef M.empty
    oldChildren <- liftEff $ newRef ds.children
    let
      selfEval = evalF ds.selfRef
      handler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler = void <<< selfEval
      handler' :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      handler' = maybe handler (\_ -> queuingHandler ds.selfRef handler) ds.pendingIn
    rendering <-
      renderSpec.render
        (handleAff <<< selfEval)
        (renderChild handler' ds.fresh ds.mkOrdBox oldChildren childrenVar lchs)
        (ds.component.render ds.state)
        ds.componentType
        ds.rendering
    children <- liftEff $ readRef childrenVar
    liftEff (readRef oldChildren) >>= traverse_ (addFinalizer lchs <=< peekVar)
    putVar var $
      DriverState
        { rendering: Just rendering
        , componentType: ds.componentType
        , component: ds.component
        , state: ds.state
        , children
        , mkOrdBox: ds.mkOrdBox
        , selfRef: ds.selfRef
        , handler: ds.handler
        , pendingIn: ds.pendingIn
        , pendingOut: ds.pendingOut
        , keyId: ds.keyId
        , fresh: ds.fresh
        }

  queuingHandler
    :: forall s f' g p o' x
     . AVar (DriverState h r s f' g p o' eff)
    -> (f' x -> Aff (HalogenEffects eff) Unit)
    -> f' x
    -> Aff (HalogenEffects eff) Unit
  queuingHandler var handler message = do
    DriverState (ds@{ pendingIn }) <- takeVar var
    case pendingIn of
      Nothing -> do
        putVar var (DriverState ds)
        handler message
      Just p ->
        putVar var (DriverState ds { pendingIn = Just (handler message : p) })

  renderChild
    :: forall f' g p
     . (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref Int
    -> (p -> OrdBox p)
    -> Ref (M.Map (OrdBox p) (AVar (DriverStateX h r g eff)))
    -> Ref (M.Map (OrdBox p) (AVar (DriverStateX h r g eff)))
    -> Ref (LifecycleHandlers eff)
    -> ComponentSlot h g (Aff (HalogenEffects eff)) p (f' Unit)
    -> Aff (HalogenEffects eff) r
  renderChild handler fresh mkOrdBox childrenInRef childrenOutRef lchs =
    unComponentSlot \p ctor k -> do
      childrenIn <- liftEff $ readRef childrenInRef
      var <- case M.pop (mkOrdBox p) childrenIn of
        Just (Tuple existing childrenIn') -> do
          liftEff $ writeRef childrenInRef childrenIn'
          pure existing
        Nothing ->
          runComponent (maybe (pure unit) handler <<< k) fresh lchs Child (force ctor)
      liftEff $ modifyRef childrenOutRef (M.insert (mkOrdBox p) var)
      unDriverStateX (\st -> renderSpec.renderChild st.keyId st.rendering) =<< peekVar var

  addInitializer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addInitializer ref =
    unDriverStateX \st -> do
      case evalF st.selfRef <$> st.component.initializer of
        Just i -> do
          liftEff $ modifyRef ref \lchs ->
            { initializers: handlePending st.selfRef : i : lchs.initializers
            , finalizers: lchs.finalizers
            }
        _ ->
          pure unit

  handlePending
    :: forall s f' g p o'
     . AVar (DriverState h r s f' g p o' eff)
    -> Aff (HalogenEffects eff) Unit
  handlePending ref = do
    DriverState (dsi@{ pendingIn }) <- takeVar ref
    putVar ref (DriverState dsi { pendingIn = Nothing })
    for_ pendingIn (sequence <<< L.reverse)
    DriverState (dso@{ pendingOut, handler }) <- takeVar ref
    putVar ref (DriverState dso { pendingOut = Nothing })
    for_ pendingOut (traverse_ handler <<< L.reverse)

  addFinalizer
    :: forall f'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r f' eff
    -> Aff (HalogenEffects eff) Unit
  addFinalizer ref =
    unDriverStateX \st -> do
      for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
        liftEff $ modifyRef ref (\lchs ->
          { initializers: lchs.initializers
          , finalizers: f : lchs.finalizers
          })
      for_ st.children (addFinalizer ref <=< peekVar)

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AVar a -> Aff (avar :: AVAR | eff) a
peekVar v = do
  a <- takeVar v
  putVar v a
  pure a


Restrict identifiers

Restrict identifiers

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = "("
prettyPrintToken RParen      = ")"
prettyPrintToken LSquare     = "["
prettyPrintToken RSquare     = "]"
prettyPrintToken Dash        = "-"
prettyPrintToken TripleDot   = "..."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray)
import Data.List ((:))
import Docopt.Parser.Base

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | TripleDot
  | Dash
  | Name String

prettyPrintToken :: Token -> String
prettyPrintToken LParen      = "("
prettyPrintToken RParen      = ")"
prettyPrintToken LSquare     = "["
prettyPrintToken RSquare     = "]"
prettyPrintToken Dash        = "-"
prettyPrintToken TripleDot   = "..."
prettyPrintToken (Name name) = name

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.string "..." *> pure TripleDot
  , Name <$> parseName
  ] <* P.skipSpaces

 where
  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  identStart :: P.Parser String Char
  identStart = lower <|> P.oneOf ['_']

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '\'']


Improve error messages on browser validation

module Genetics.Browser.Config
       where

import Prelude
import Control.Monad.Except (withExcept)
import Data.Array (null)
import Data.Foldable (all)
import Data.Foreign (F, Foreign, ForeignError(..), fail, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Foreign.Keys (keys)
import Data.Maybe (isJust)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Config.Track (TracksMap, readTrackType)
import Unsafe.Coerce (unsafeCoerce)

newtype BrowserConfig = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      }

readTaggedWithError :: forall a. String -> String -> Foreign -> F a
readTaggedWithError s e f = withExcept ((<>) (pure $ ForeignError e)) $ unsafeReadTagged s f

parseBrowserConfig :: Foreign -> F BrowserConfig
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= readTaggedWithError "Function" "Error on 'wrapRenderer':"
  browser <- f ! "browser" >>= readTaggedWithError "Function" "Error on 'browser':"
  tracks <- f ! "tracks"
  tracksKeys <- (map readTrackType) <$> keys tracks
  when (null tracksKeys) $ fail $ ForeignError "TracksMap is empty"
  when (not $ all isJust tracksKeys) $ fail $ ForeignError "TracksMap keys are not all TrackType"
  let tracks' = unsafeCoerce tracks
  pure $ BrowserConfig { wrapRenderer, browser, tracks: tracks' }

module Genetics.Browser.Config
       where

import Prelude
import Data.Array (null)
import Data.Foldable (all)
import Data.Foreign (F, Foreign, ForeignError(..), fail, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Foreign.Keys (keys)
import Data.Maybe (isJust)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Config.Track (TracksMap, readTrackType)
import Unsafe.Coerce (unsafeCoerce)

newtype BrowserConfig = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      }

parseBrowserConfig :: Foreign -> F BrowserConfig
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= unsafeReadTagged "Function"
  browser <- f ! "browser" >>= unsafeReadTagged "Function"
  tracks <- f ! "tracks"
  tracksKeys <- (map readTrackType) <$> keys tracks
  when (null tracksKeys) $ fail $ ForeignError "TracksMap is empty"
  when (not $ all isJust tracksKeys) $ fail $ ForeignError "TracksMap keys are not all TrackType"

  let tracks' = unsafeCoerce tracks
  pure $ BrowserConfig { wrapRenderer, browser, tracks: tracks' }


Improve debug labels

Improve debug labels

module Neodoc.ArgParser.Parser where

import Prelude
import Debug.Trace hiding (trace)
import Debug.Profile
import Data.Generic
import Data.List (
  List(..), some, singleton, filter, fromFoldable, last, groupBy, sortBy, (:)
, null, concat, mapWithIndex, length, take, drop, toUnfoldable, catMaybes, nub
, reverse)
import Data.Array as Array
import Data.List.Partial as LU
import Data.Bifunctor (lmap)
import Data.Set as Set
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Data.Function (on)
import Data.Tuple (Tuple(..), snd, fst)
import Data.Tuple.Nested ((/\))
import Data.Either (Either(..))
import Data.String as String
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.Maybe (Maybe(..), isJust, maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Foldable.Extra (findMap)
import Data.Foldable (
  class Foldable, maximumBy, all, intercalate, sum, any, elem, find)
import Data.Map as Map
import Data.Map (Map)
import Data.Pretty (pretty, class Pretty)
import Control.Alt ((<|>))
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Monad.State
import Control.Monad.State as State
import Partial.Unsafe
import Data.NonEmpty.Extra as NonEmpty

import Neodoc.Value (Value(..))
import Neodoc.Value as Value
import Neodoc.Value.RichValue (RichValue(..), unRichValue)
import Neodoc.Value.RichValue as RichValue
import Neodoc.Value.Origin (Origin(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Spec (Spec(..), Toplevel)
import Neodoc.Env
import Neodoc.Data.Layout
import Neodoc.Data.Layout as Layout
import Neodoc.Data.Description
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.Chunk
import Neodoc.Data.Indexed
import Neodoc.Data.IndexedLayout
import Neodoc.Data.LayoutConversion
import Neodoc.OptionAlias as OptionAlias
import Neodoc.ArgKey (ArgKey)
import Neodoc.ArgKey.Class (toArgKey)
import Neodoc.ArgParser.Type
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Token as Token
import Neodoc.ArgParser.Argument
import Neodoc.ArgParser.Lexer as L
import Neodoc.ArgParser.Evaluate
import Neodoc.ArgParser.Required
import Neodoc.ArgParser.Combinators
import Neodoc.ArgParser.Fallback
import Neodoc.ArgParser.Result
import Neodoc.ArgParser.KeyValue
import Neodoc.ArgParser.Profile
import Neodoc.ArgParser.Arg hiding (getId)
import Neodoc.ArgParser.Debug
import Neodoc.ArgParser.Arg as Arg

type ChunkedLayout a = Layout (Chunk a)

initialState :: ParseState
initialState = {
  depth: 0
, hasTerminated: false
}

initialGlobalState :: GlobalParseState
initialGlobalState = {
  deepestError: Nothing
, isKnownCache: Map.empty
}

{-
A recursive layout structure suited for parsing.

Each nested grouping indicates if it is ought to be considered "fixed", or
"free" in terms of the groups' occurence rules. The rules are simple:
Groups that contain any branch that contains any positional argument are now
"fixed". This is restriction is set in place in order to allow re-evaluating
the group in face of repetition:

"u: (-a | -b)..." says that the group *in it's entirety* should be able to occur
one or more times. This means that all of these inputs are valid: "-ab", "-bb",
"-abab", "-abbbab".

An alternative contemplation was to "lock" the branch after the initial match.
This, in effect, alters the spec "on-the-fly" for this pattern's evaluation.
This would cause "u: (-a | b)..." to only match inputs: "-a", "-aa", ..., "-b",
"-bb" and so on, mixing "a"s and "b"s would be considered a failure. Neodoc
does not yet implement such a pattern because it is less general. The above
could also be achieved, more flexibly, using "u: (-a...|-b...)".

Secondly, this data structure presents and "id", suitable for quick cache
lookups and identification of elements later on.
-}
type ParseBranch a = NonEmpty List (ParseLayout a)
data ParseLayout a
  = ParseElem
      Int     -- id
      Boolean -- free?
      a
  | ParseGroup
      Int     -- id
      Boolean -- free?
      Boolean -- optional?
      Boolean -- repeatable?
      (NonEmpty List (ParseBranch a))
type ArgParseLayout = ParseLayout Arg

getElem :: ∀ a. ParseLayout a -> Maybe a
getElem (ParseElem _ _ x) = Just x
getElem _ = Nothing

getId :: ∀ a. ParseLayout a -> Int
getId (ParseElem id _ _) = id
getId (ParseGroup id _ _ _ _) = id

derive instance genericParseLayout :: (Generic a) => Generic (ParseLayout a)
instance showParseLayout :: (Generic a, Show a) => Show (ParseLayout a) where
  show = gShow

instance eqParseLayout :: Eq (ParseLayout a) where
  eq = eq `on` getId

instance prettyParseLayout :: (Pretty a) => Pretty (ParseLayout a) where
  pretty (ParseElem id free x)
    = "E(" <> show id <> ":"
        <> (if free then "<*" else "<!")
        <> pretty x
        <> (if free then "*>" else "!>")
        <> ")"
  pretty (ParseGroup id free o r xs)
    = "G"
        <> (if o then "[" else "(")
        <> show id <> ":"
        <> (if free then "<*" else "<!")
        <> (intercalate "|" (pretty <$> xs))
        <> (if free then "*>" else "!>")
        <> (if o then "]" else ")")
        <> (if r then "..." else "")

parse
  :: ∀ r
   . Spec SolvedLayout
  -> Options r
  -> Env
  -> List PositionedToken
  -> Either (ParseError ArgParseError) ArgParseResult
parse (spec@(Spec { layouts, descriptions })) options env tokens = do
  runParser { env, options, spec } initialState initialGlobalState tokens $
    let hasEmpty = any null layouts
        toplevels = concat (NonEmpty.toList layouts)

        parsers :: List (ArgParser r ArgParseResult)
        parsers = toplevels <#> \branch ->
          let branch' = toArgBranch options env descriptions branch
              branch'' = toParseBranch (NonEmpty.toList branch')
           in do
            vs <- parseBranch 0 true branch''
            eof
            pure $ ArgParseResult (Just branch) vs

        parsers' :: List (ArgParser r ArgParseResult)
        parsers' = parsers
            -- if there were empty any layouts, such as for example:
            --    usage: prog
            --       or: prog
            -- then we consolidate those into a single, artificial
            -- parse whose only requirement is that there be no input.
            <> if hasEmpty
                  then singleton $ eof $> ArgParseResult Nothing Nil
                  else Nil
     in if null parsers
          then eof $> ArgParseResult Nothing Nil
          else evalParsers (byOrigin <<< getResult) parsers
  where
  eof :: ∀ r. ArgParser r Unit
  eof = do
    input <- getInput
    case input of
      Nil  -> pure unit
      toks -> do
        { deepestError } <- getGlobalState
        case deepestError of
          Just (_ /\ e) -> fail' e
          Nothing -> do
            kToks <- for toks \(pTok@(PositionedToken tok _ _)) -> do
              isKnown <- isKnownToken' tok
              pure if isKnown
                then known pTok
                else unknown pTok
            fail' $ unexpectedInputError Nil kToks
parseBranch
  :: ∀ r
   . Int
  -> Boolean -- allow substitutions?
  -> List ArgParseLayout
  -> ArgParser r (List KeyValue)
parseBranch _ _ Nil = pure Nil
parseBranch l sub xs = profile "parse-branch" \_-> do
  { options } <- getConfig
  let xs' = if not options.laxPlacement
            then groupBy (eq `on` _isFree) xs
            else singleton xs
  concat <$> for xs' (solve l options.repeatableOptions sub)
  where
  _isFree :: ArgParseLayout -> Boolean
  _isFree (ParseGroup _ f _ _ _) = f
  _isFree (ParseElem _ f _) = f

{-
  we iterate over the set of required arguments `req`.
  should we fail to make a match for any `x` in `req`, we move `x` to `res`.
  should we be able to make a match with a successive `x'` in `req`, we
  release all arguments from the "reserve" (`res`) back into `req` and re-
  evaluate. should all `x` in `req` fail, we try to consume *anything* with
  `rep`. if the input changes, we keep going - if it does not we conclude that
  there's no match on this branch.
-}
solve
  :: ∀ r
   . Int                 -- recursive level
  -> Boolean             -- `opts.repeatableOptions`
  -> Boolean             -- allow substitutions?
  -> List ArgParseLayout -- the required arguments
  -> ArgParser r (List KeyValue)
solve l repOpts sub req = go l sub req Nil Nil Nil
  where
  go
    :: Int                 -- the recursive level
    -> Boolean             -- allow substitutions?
    -> List ArgParseLayout -- the required arguments
    -> List ArgParseLayout -- repeatable arguments
    -> List ArgParseLayout -- the "reserve"
    -> List KeyValue       -- the output
    -> ArgParser r (List KeyValue)
  go l' sub' req rep res out = do
    input       <- getInput
    { options } <- getConfig
    { depth }   <- getState
    trace l' \_->
      "solve: req = " <> pretty req
        <> ", rep = " <> pretty rep
        <> ", res = " <> pretty res
        <> ", sub = " <> show sub
        <> ", in = "  <> pretty input
        <> ", out = " <> pretty out

    -- 1. try making a match for any arg in `req` w/o allowing substitutions.
    --    if we make a match, we proceed *and never look back*. If we do not
    --    succeed with any argument, we try the `rep` list.
    trace l' \_-> "solve: trying via argv"
    mKv /\ req' /\ _ <- (_lmap Just <$> (try $ match (l' + 1) false req))
                    <|> pure (Nothing /\ req /\ false)
    trace l' \_-> "solve: req' = " <> pretty req' <> " out = " <> show (pretty <$> mKv)
    case mKv of
      Just kvs@(_:_) -> do
        trace l' \_-> "solve: matched on argv: " <> pretty kvs
        let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
            rep' = nub (rep <> rRep)
        go (l' + 1) sub' (req' <> res) rep' Nil (out <> kvs)
      _ -> do
        -- 2. if we did not manage to make a single `req` parse, we ought to try
        --    if any of our args in `rep` is now able to parse. We consume at
        --    most one and flush `res` in case of success. The reason for
        --    flushing is, is that a success w/o substitution *necessarily*
        --    means we consumed input - hence we must try previously failed
        --    `req` again.
        --    note: the insertion of `res` back into `req` *does matter*, needs
        --          more thought though, as to put it into the front or back.
        trace l' \_-> "solve: trying via rep"
        mKv' /\ rep' /\ _ <- (_lmap Just <$> (try $ match (l' + 1) false rep))
                          <|> pure (Nothing /\ rep /\ false)
        case mKv' of
          Just kvs@(_:_) -> do
            trace l' \_-> "solve: matched via rep: " <> pretty kvs
            let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
                rep'' = nub (rep' <> rRep)
            go (l' + 1) sub' (req <> res) rep'' Nil (out <> kvs)
          -- 3. If we still did not manage to make a match, things aren't
          --    looking too great. It's time for drastic measures. If the parent
          --    is allowing us to, we repeat this above, but allow substitutions
          --    this time. At this point, "anything" goes. If we find a match
          --    whose result contains any value with origin `Argv`, we must
          --    again try again all prior inputs as new input means new chances
          --    of a successful match.
          _ -> do
            case req' of
              Nil -> do
                trace l' \_-> "solve: empty req' after rep. done"
                pure out
              _:_ | sub ->
                let
                  exhaust
                    :: List ArgParseLayout
                    -> List KeyValue
                    -> ArgParser r (List KeyValue)
                  exhaust Nil out' = pure out'
                  exhaust req'' out' = do
                    kVs'' /\ req''' /\ changed <- try $ match (l' + 1) true req''
                    trace l' \_ ->
                         "solve: matched via sub"
                      <> " kVs''" <> pretty kVs''
                      <> ", changed = " <> show changed
                      <> ", req''' = " <> pretty req'''
                    -- check if we consumed input. If we did, we must rinse
                    -- and repeat the entire process with the new input.
                    if (not (null kVs'')) && (any (isFrom Origin.Argv <<< snd) kVs'' || changed)
                      then go (l' + 1) false req''' rep res (out' <> kVs'')
                      else exhaust req''' (out' <> kVs'')
                 in do
                  trace l' \_-> "solve: trying via sub"
                  exhaust req' out
              xs -> do
                trace l' \_-> "solve: failed to match: " <> pretty xs
                fail "..." -- XXX: throw proper error here

  _lmap f (a /\ b /\ c) = f a /\ b /\ c

  _toElem :: Arg -> ArgParseLayout
  _toElem x =
    -- note: we know it's not fixed since we only use this function
    -- to re-inject options for `opts.repeatableOptions`.
    let isFree = true
     in ParseElem (Arg.getId x) isFree x

  _isRepeatable :: Arg -> Boolean
  _isRepeatable x = Arg.isArgRepeatable x || (repOpts && Arg.isOption x)

  {-
    Try to make a match from any of the input layouts.
    This parser deals with subsituting values, culling optional args and ensures
    order is maintained in lax-placement mode.
  -}
  match
    :: Int -- the recursive level
    -> Boolean -- allow substitutions?
    -> List ArgParseLayout
    -> ArgParser r (Tuple (Tuple
        (List KeyValue)        -- the key-value pairs that where yielded
        (List ArgParseLayout)) -- the layouts that did *NOT* match
        Boolean)               -- has this changed the input?
  match l sub xs = go' false xs Nil
    where
    go' locked (x:xs) ys = (do
      trace l \_-> "match: try"
        <> " x = " <> pretty x
        <> ", xs = " <> pretty xs
        <> ", ys = " <> pretty ys
        <> ", locked = " <> show locked
        <> ", sub = " <> show sub
      if _isFixed x && locked
        then go' true xs (x:ys)
        else do
          vs <- try $ parseLayout (l + 1) (sub && not locked) x
          trace l \_-> "match: return"
            <> " x = " <> pretty x
            <> ", xs = " <> pretty xs
            <> ", ys = " <> pretty ys
            <> ", vs = " <> pretty vs
            <> ", locked = " <> show locked
            <> ", sub = " <> show sub
          pure (vs /\ (sortBy (compare `on` getId) $ xs <> ys) /\ locked)
    ) `catch` \_ e -> do
      go' (locked || _isFixed x) xs (x:ys)

    {-
      Evaluate the result. We've tried all `req` items agains the same input
      now and none of them managed to make a match. Since all of these items
      are "free", substituting or removing one of them is not going to make abs
      difference for the others.
    -}
    go' locked Nil ys = do
      i <- getInput
      let ys' = sortBy (compare `on` getId) ys
      ys'' /\ changed <- pure do
       if locked
        then dropFirst (\x -> _isOptional x && _isFixed x) ys'
        else ys' /\ false

      trace l \_-> "match: eval"
          <> " ys = " <> pretty ys
          <> ", ys' = " <> pretty ys'
          <> ", ys'' = " <> pretty ys''
          <> ", locked = " <> show locked
          <> ", sub = " <> show sub

      case if sub then filter (not <<< _isOptional) ys'' else ys'' of
        Nil -> do
          trace l \_-> "match: succeeded!"

          -- substitute all leaf elements. we ignore groups because these groups
          -- have failed to parse irrespective of substitution, so they are a
          -- not considered a legible match.
          let subVs = catMaybes $ ys'' <#> case _ of
                        e@(ParseElem _ _ x) -> do
                          v <- Arg.getFallback x
                          pure (e /\ x /\ v)
                        _ -> Nothing

          -- return as a triplet, the values (only fallbacks), the layouts
          -- that where responsible for the values and finally if either have
          -- been locked (which indicates a possible change in input) or if
          -- we noticed a change during `dropFirst` (also releated to locking /
          -- positionals)
          pure ((_rest <$> subVs) /\ (_fst <$> subVs) /\ (locked || changed))
        zs | changed -> go' false zs Nil
        z:zs -> do
          trace l \_-> "match: failed!"
          i <- getInput
          { depth } <- getState
          case i of
            Nil ->
              let c = toSimpleBranch (z:zs)
                  e = missingArgumentsError (unsafePartial $ NonEmpty.fromList' c)
               in setErrorAtDepth depth e *> fail' e
            _ -> do
              kToks <- for i \(pTok@(PositionedToken tok _ _)) -> do
                isKnown <- isKnownToken' tok
                pure if isKnown
                  then known pTok
                  else unknown pTok
              let e = unexpectedInputError (toSimpleBranch zs) kToks
              setErrorAtDepth depth e *> fail' e

  dropFirst f xs = go' xs Nil
    where go' Nil out = out /\ false
          go' (x:xs) out = if f x then (out <> xs) /\ true else go' xs (x:out)

  _fst  (a /\ b /\ c) = a
  _rest (a /\ b /\ c) = b /\ c

  _isFixed :: ArgParseLayout -> Boolean
  _isFixed (ParseGroup _ f _ _ _) = not f
  _isFixed (ParseElem _ f _) = not f

  _hasFallback :: ArgParseLayout -> Boolean
  _hasFallback (ParseElem _ _ x) = isJust (Arg.getFallback x)
  _hasFallback _ = false

  _isOptional :: ArgParseLayout -> Boolean
  _isOptional (ParseGroup _ _ o _ _) = o
  _isOptional (ParseElem _ _ x) = Arg.isOptional x

byOrigin :: List KeyValue -> Int
byOrigin vs = sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs

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

parseLayout
  :: ∀ r
   . Int
  -> Boolean
  -> ArgParseLayout
  -> ArgParser r (List KeyValue)
parseLayout l sub x = do
  { options } <- getConfig
  go options x
  where
  go opts (g@(ParseGroup _ _ _ r branches)) =
    let parsers = NonEmpty.toList branches <#> \branch ->
                    let args = NonEmpty.toList branch
                     in parseBranch l sub args
        p = evalParsers byOrigin parsers
     in do
      vs <- p
      if r && any (isFrom Origin.Argv <<< snd) vs
        then loop p vs
        else pure vs

     where
     loop p acc = do
        vs <- p <|> pure Nil
        if any (isFrom Origin.Argv <<< snd) vs
          then loop p (acc <> vs)
          else pure (acc <> vs)

  go opts (ParseElem _ _ x) =
    let arg = Arg.getArg x
        fromArgv = do
          RichValue.from Origin.Argv <$> parseArg arg
          <* modifyDepth (_ + 1)
     in do
      if sub
        then singleton <<< Tuple x <$> case Arg.getFallback x of
              Just v -> fromArgv <|> pure v
              _      -> fromArgv
        else
          let nTimes = if Arg.isArgRepeatable x then some else liftM1 singleton
           in nTimes $ Tuple x <$> fromArgv

{-
  Parse a single argument. We do not substitute and ignore repetitions.
-}
parseArg
  :: ∀ r
   . SolvedLayoutArg
  -> ArgParser r Value
parseArg = go
  where
  go (Solved.Positional n _) = positional n n
  go (Solved.Command    n _) = command    n n
  go (Solved.Stdin         ) = stdin
  go (Solved.EOA           ) = eoa <|> (pure $ ArrayValue [])
  go (Solved.Option a  mA r) = do
    input       <- getInput
    { options } <- getConfig
    case input of
      (PositionedToken token _ _) : _
        | case token of
            LOpt _ _   -> true
            SOpt _ _ _ -> true
            _          -> false
        -> do
          aliases /\ def /\ env <- do
            description <- lookupDescription' a
            case description of
              (OptionDescription aliases' _ _ def' env') ->
                pure $ aliases' /\ def' /\ env'
              _ -> fail' $ internalError "invalid option description"
          let
            ns = NonEmpty.toList $ aliases <#> case _ of
                  OptionAlias.Short f -> Left  f
                  OptionAlias.Long  n -> Right n
            longAliases = mrights ns
            shortAliases = mlefts ns
            term = any (_ `elem` options.stopAt) $ aliases <#> case _ of
                      OptionAlias.Short s -> "-"  <> String.singleton s
                      OptionAlias.Long  n -> "--" <> n

          -- note: safe to be unsafe because of pattern match above
          OptRes v canTerm canRepeat <- unsafePartial case token of
            LOpt _ _ ->
              case longAliases of
                Nil -> fail "Option has no long alias"
                _   -> choice $ longAliases <#> \alias -> try do
                        longOption term alias mA
            SOpt _ _ _ ->
              case shortAliases of
                Nil -> fail "Option has no short alias"
                _   -> choice $ shortAliases <#> \alias -> try do
                        shortOption term alias mA

          -- try terminating at this option
          if term && canTerm
              then do
                vs <- fail "not implemented" -- TODO: terminate x
                pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
              else do
                if isJust mA && r && canRepeat
                    then do
                      vs <- Array.many optionArgument
                      pure (ArrayValue (Value.intoArray v <> vs))
                    else pure v
      _ -> fail "Expected long or short option"

{-
  Convert an ordinary layout to a layout suitable for parsing. Each layout and
  element get their own unique id in a shared namespace. For example:
    `G0(E1, G2(E3))`
      where `G` denotes a Group and `E` denotes an element.
  Further, we determine up-front which layout is "free" and which one is "fixed",
  saving us unncessary traversals during the hot phase of the parse.
-}
toParseBranch
  :: List ArgLayout
  -> List ArgParseLayout
toParseBranch xs = evalState (for xs go) 0
  where
  nextId = State.get <* State.modify (_ + 1)
  go (e@(Elem x)) = do
    i <- nextId
    pure (ParseElem i (Arg.isFreeLayout e) (Arg.setId i x))
  go (g@(Group o r xs)) = do
    i <- nextId
    ParseGroup i (Arg.isFreeLayout g) o r <$> do
      for xs (traverse go)

toSimpleBranch
  :: List ArgParseLayout
  -> List SolvedLayout
toSimpleBranch Nil = Nil
toSimpleBranch (x:xs) = go x : toSimpleBranch xs
  where
  go (ParseElem _ _ x) = Elem $ Arg.getArg x
  go (ParseGroup _ _ o r xs) = Group o r $ (go <$> _) <$> xs

{-
  Convert an ordinary branch of solved arguments into a branch of `Arg`s.
  We perform this step to cache some information right along-side each argument,
  such as it's `ArgKey` and fallback value. This is going to save us from doing
  this during the hot phase of the parse.

  note: we set all `id`s to 0 and copy them later from the containing layout's
        `id`s. this allows us to cache on the arg and layout level, and to
        associate across the two.
-}
toArgBranch
  :: ∀ r
   . Options r
  -> Env
  -> List Description
  -> Branch SolvedLayoutArg
  -> Branch Arg
toArgBranch options env descriptions x = go <$> x
  where
  go (Elem x) =
    let description = case x of
          (Option alias _ _) -> findDescription alias descriptions
          _                  -> Nothing
        fallback = do
          v <- unRichValue <$> getFallbackValue options env description x
          pure $ RichValue v {
            value = if Solved.isElemRepeatable x
                      then ArrayValue $ Value.intoArray v.value
                      else v.value
          }
     in Elem $ Arg 0 x (toArgKey x) fallback false
  -- note: uncomment to collapse [-a] into an optional -a
  -- go (Group o r (((e@(Elem _)):|Nil):|Nil))
  --   = let e' = go e
  --      in unsafePartial $ case e' of
  --         Elem (Arg i x k mV o') ->
  --           Elem $ Arg i (Solved.setElemRepeatable r x) k mV (o || o')
  go (Group o r xs) = Group o r $ (go <$> _) <$> xs

isKnownToken'
  :: ∀ r
   . Token
  -> ArgParser r Boolean
isKnownToken' tok = do
  { spec } <- getConfig
  { isKnownCache } <- getGlobalState
  case Map.lookup tok isKnownCache of
    Just b -> pure b
    Nothing ->
      let isKnown = isKnownToken spec tok
       in isKnown <$ modifyGlobalState \s -> s {
            isKnownCache = Map.alter (const (Just isKnown)) tok s.isKnownCache
          }

{-
  Determine if a given token is considered known
-}
isKnownToken
  :: Spec SolvedLayout
  -> Token
  -> Boolean
isKnownToken (Spec { layouts, descriptions }) tok = occuresInDescs || occuresInLayouts
  where
  occuresInDescs = any matchesDesc descriptions
    where
    matchesDesc (OptionDescription as _ _ _ _) = test tok
      where
      test (Token.LOpt n _)   = elem (OptionAlias.Long n) as
      test (Token.SOpt s _ _) = elem (OptionAlias.Short s) as
      test _ = false
    matchesDesc _ = false
  occuresInLayouts = any (any (any matchesLayout)) layouts
    where
    matchesLayout (Group _ _ xs) = any (any matchesLayout) xs
    matchesLayout (Elem x) = test tok x
      where
      test (Token.LOpt n _)   (Solved.Option a _ _) = OptionAlias.Long n == a
      test (Token.SOpt s _ _) (Solved.Option a _ _) = OptionAlias.Short s == a
      test (Token.Lit n)      (Solved.Command n' _) = n == n'
      test (Token.EOA _)      (Solved.EOA)          = true
      test (Token.Stdin)      (Solved.Stdin)        = true
      test _ _ = false

module Neodoc.ArgParser.Parser where

import Prelude
import Debug.Trace hiding (trace)
import Debug.Profile
import Data.Generic
import Data.List (
  List(..), some, singleton, filter, fromFoldable, last, groupBy, sortBy, (:)
, null, concat, mapWithIndex, length, take, drop, toUnfoldable, catMaybes, nub
, reverse)
import Data.Array as Array
import Data.List.Partial as LU
import Data.Bifunctor (lmap)
import Data.Set as Set
import Data.List.Lazy (take, repeat, toUnfoldable) as LL
import Data.Function (on)
import Data.Tuple (Tuple(..), snd, fst)
import Data.Tuple.Nested ((/\))
import Data.Either (Either(..))
import Data.String as String
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.Maybe (Maybe(..), isJust, maybe, fromJust)
import Data.Traversable (for, traverse)
import Data.Foldable.Extra (findMap)
import Data.Foldable (
  class Foldable, maximumBy, all, intercalate, sum, any, elem, find)
import Data.Map as Map
import Data.Map (Map)
import Data.Pretty (pretty, class Pretty)
import Control.Alt ((<|>))
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Monad.State
import Control.Monad.State as State
import Partial.Unsafe
import Data.NonEmpty.Extra as NonEmpty

import Neodoc.Value (Value(..))
import Neodoc.Value as Value
import Neodoc.Value.RichValue (RichValue(..), unRichValue)
import Neodoc.Value.RichValue as RichValue
import Neodoc.Value.Origin (Origin(..))
import Neodoc.Value.Origin as Origin
import Neodoc.Spec (Spec(..), Toplevel)
import Neodoc.Env
import Neodoc.Data.Layout
import Neodoc.Data.Layout as Layout
import Neodoc.Data.Description
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.Chunk
import Neodoc.Data.Indexed
import Neodoc.Data.IndexedLayout
import Neodoc.Data.LayoutConversion
import Neodoc.OptionAlias as OptionAlias
import Neodoc.ArgKey (ArgKey)
import Neodoc.ArgKey.Class (toArgKey)
import Neodoc.ArgParser.Type
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Token as Token
import Neodoc.ArgParser.Argument
import Neodoc.ArgParser.Lexer as L
import Neodoc.ArgParser.Evaluate
import Neodoc.ArgParser.Required
import Neodoc.ArgParser.Combinators
import Neodoc.ArgParser.Fallback
import Neodoc.ArgParser.Result
import Neodoc.ArgParser.KeyValue
import Neodoc.ArgParser.Profile
import Neodoc.ArgParser.Arg hiding (getId)
import Neodoc.ArgParser.Debug
import Neodoc.ArgParser.Arg as Arg

type ChunkedLayout a = Layout (Chunk a)

initialState :: ParseState
initialState = {
  depth: 0
, hasTerminated: false
}

initialGlobalState :: GlobalParseState
initialGlobalState = {
  deepestError: Nothing
, isKnownCache: Map.empty
}

{-
A recursive layout structure suited for parsing.

Each nested grouping indicates if it is ought to be considered "fixed", or
"free" in terms of the groups' occurence rules. The rules are simple:
Groups that contain any branch that contains any positional argument are now
"fixed". This is restriction is set in place in order to allow re-evaluating
the group in face of repetition:

"u: (-a | -b)..." says that the group *in it's entirety* should be able to occur
one or more times. This means that all of these inputs are valid: "-ab", "-bb",
"-abab", "-abbbab".

An alternative contemplation was to "lock" the branch after the initial match.
This, in effect, alters the spec "on-the-fly" for this pattern's evaluation.
This would cause "u: (-a | b)..." to only match inputs: "-a", "-aa", ..., "-b",
"-bb" and so on, mixing "a"s and "b"s would be considered a failure. Neodoc
does not yet implement such a pattern because it is less general. The above
could also be achieved, more flexibly, using "u: (-a...|-b...)".

Secondly, this data structure presents and "id", suitable for quick cache
lookups and identification of elements later on.
-}
type ParseBranch a = NonEmpty List (ParseLayout a)
data ParseLayout a
  = ParseElem
      Int     -- id
      Boolean -- free?
      a
  | ParseGroup
      Int     -- id
      Boolean -- free?
      Boolean -- optional?
      Boolean -- repeatable?
      (NonEmpty List (ParseBranch a))
type ArgParseLayout = ParseLayout Arg

getElem :: ∀ a. ParseLayout a -> Maybe a
getElem (ParseElem _ _ x) = Just x
getElem _ = Nothing

getId :: ∀ a. ParseLayout a -> Int
getId (ParseElem id _ _) = id
getId (ParseGroup id _ _ _ _) = id

derive instance genericParseLayout :: (Generic a) => Generic (ParseLayout a)
instance showParseLayout :: (Generic a, Show a) => Show (ParseLayout a) where
  show = gShow

instance eqParseLayout :: Eq (ParseLayout a) where
  eq = eq `on` getId

instance prettyParseLayout :: (Pretty a) => Pretty (ParseLayout a) where
  pretty (ParseElem id free x)
    = "E(" <> show id <> ":"
        <> (if free then "<*" else "<!")
        <> pretty x
        <> (if free then "*>" else "!>")
        <> ")"
  pretty (ParseGroup id free o r xs)
    = "G"
        <> (if o then "[" else "(")
        <> show id <> ":"
        <> (if free then "<*" else "<!")
        <> (intercalate "|" (pretty <$> xs))
        <> (if free then "*>" else "!>")
        <> (if o then "]" else ")")
        <> (if r then "..." else "")

parse
  :: ∀ r
   . Spec SolvedLayout
  -> Options r
  -> Env
  -> List PositionedToken
  -> Either (ParseError ArgParseError) ArgParseResult
parse (spec@(Spec { layouts, descriptions })) options env tokens = do
  runParser { env, options, spec } initialState initialGlobalState tokens $
    let hasEmpty = any null layouts
        toplevels = concat (NonEmpty.toList layouts)

        parsers :: List (ArgParser r ArgParseResult)
        parsers = toplevels <#> \branch ->
          let branch' = toArgBranch options env descriptions branch
              branch'' = toParseBranch (NonEmpty.toList branch')
           in do
            vs <- parseBranch 0 true branch''
            eof
            pure $ ArgParseResult (Just branch) vs

        parsers' :: List (ArgParser r ArgParseResult)
        parsers' = parsers
            -- if there were empty any layouts, such as for example:
            --    usage: prog
            --       or: prog
            -- then we consolidate those into a single, artificial
            -- parse whose only requirement is that there be no input.
            <> if hasEmpty
                  then singleton $ eof $> ArgParseResult Nothing Nil
                  else Nil
     in if null parsers
          then eof $> ArgParseResult Nothing Nil
          else evalParsers (byOrigin <<< getResult) parsers
  where
  eof :: ∀ r. ArgParser r Unit
  eof = do
    input <- getInput
    case input of
      Nil  -> pure unit
      toks -> do
        { deepestError } <- getGlobalState
        case deepestError of
          Just (_ /\ e) -> fail' e
          Nothing -> do
            kToks <- for toks \(pTok@(PositionedToken tok _ _)) -> do
              isKnown <- isKnownToken' tok
              pure if isKnown
                then known pTok
                else unknown pTok
            fail' $ unexpectedInputError Nil kToks
parseBranch
  :: ∀ r
   . Int
  -> Boolean -- allow substitutions?
  -> List ArgParseLayout
  -> ArgParser r (List KeyValue)
parseBranch _ _ Nil = pure Nil
parseBranch l sub xs = profile "parse-branch" \_-> do
  { options } <- getConfig
  let xs' = if not options.laxPlacement
            then groupBy (eq `on` _isFree) xs
            else singleton xs
  concat <$> for xs' (solve l options.repeatableOptions sub)
  where
  _isFree :: ArgParseLayout -> Boolean
  _isFree (ParseGroup _ f _ _ _) = f
  _isFree (ParseElem _ f _) = f

{-
  we iterate over the set of required arguments `req`.
  should we fail to make a match for any `x` in `req`, we move `x` to `res`.
  should we be able to make a match with a successive `x'` in `req`, we
  release all arguments from the "reserve" (`res`) back into `req` and re-
  evaluate. should all `x` in `req` fail, we try to consume *anything* with
  `rep`. if the input changes, we keep going - if it does not we conclude that
  there's no match on this branch.
-}
solve
  :: ∀ r
   . Int                 -- recursive level
  -> Boolean             -- `opts.repeatableOptions`
  -> Boolean             -- allow substitutions?
  -> List ArgParseLayout -- the required arguments
  -> ArgParser r (List KeyValue)
solve l repOpts sub req = go l sub req Nil Nil Nil
  where
  go
    :: Int                 -- the recursive level
    -> Boolean             -- allow substitutions?
    -> List ArgParseLayout -- the required arguments
    -> List ArgParseLayout -- repeatable arguments
    -> List ArgParseLayout -- the "reserve"
    -> List KeyValue       -- the output
    -> ArgParser r (List KeyValue)
  go l' sub' req rep res out = do
    input       <- getInput
    { options } <- getConfig
    { depth }   <- getState
    trace l' \_->
           "req = " <> pretty req
      <> ", rep = " <> pretty rep
      <> ", res = " <> pretty res
      <> ", sub = " <> show sub
      <> ", in = "  <> pretty input
      <> ", out = " <> pretty out

    -- 1. try making a match for any arg in `req` w/o allowing substitutions.
    --    if we make a match, we proceed *and never look back*. If we do not
    --    succeed with any argument, we try the `rep` list.
    trace l' \_-> "trying via argv"
    mKv /\ req' /\ _ <- (_lmap Just <$> (try $ match l' false req))
                    <|> pure (Nothing /\ req /\ false)
    trace l' \_-> "req' = " <> pretty req' <> " out = " <> show (pretty <$> mKv)
    case mKv of
      Just kvs@(_:_) -> do
        trace l' \_-> "matched on argv: " <> pretty kvs
        let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
            rep' = nub (rep <> rRep)
        go (l' + 1) sub' (req' <> res) rep' Nil (out <> kvs)
      _ -> do
        -- 2. if we did not manage to make a single `req` parse, we ought to try
        --    if any of our args in `rep` is now able to parse. We consume at
        --    most one and flush `res` in case of success. The reason for
        --    flushing is, is that a success w/o substitution *necessarily*
        --    means we consumed input - hence we must try previously failed
        --    `req` again.
        --    note: the insertion of `res` back into `req` *does matter*, needs
        --          more thought though, as to put it into the front or back.
        trace l' \_-> "trying via rep"
        mKv' /\ rep' /\ _ <- (_lmap Just <$> (try $ match l' false rep))
                          <|> pure (Nothing /\ rep /\ false)
        case mKv' of
          Just kvs@(_:_) -> do
            trace l' \_-> "matched via rep: " <> pretty kvs
            let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
                rep'' = nub (rep' <> rRep)
            go (l' + 1) sub' (req <> res) rep'' Nil (out <> kvs)
          -- 3. If we still did not manage to make a match, things aren't
          --    looking too great. It's time for drastic measures. If the parent
          --    is allowing us to, we repeat this above, but allow substitutions
          --    this time. At this point, "anything" goes. If we find a match
          --    whose result contains any value with origin `Argv`, we must
          --    again try again all prior inputs as new input means new chances
          --    of a successful match.
          _ -> do
            case req' of
              Nil -> do
                trace l' \_-> "empty req' after rep. done"
                pure out
              _:_ | sub ->
                let
                  exhaust
                    :: List ArgParseLayout
                    -> List KeyValue
                    -> ArgParser r (List KeyValue)
                  exhaust Nil out' = pure out'
                  exhaust req'' out' = do
                    kVs'' /\ req''' /\ changed <- try $ match l' true req''
                    trace l' \_ ->
                         "matched via sub"
                      <> " kVs''" <> pretty kVs''
                      <> ", changed = " <> show changed
                      <> ", req''' = " <> pretty req'''
                    -- check if we consumed input. If we did, we must rinse
                    -- and repeat the entire process with the new input.
                    if (not (null kVs'')) && (any (isFrom Origin.Argv <<< snd) kVs'' || changed)
                      then go (l' + 1) false req''' rep res (out' <> kVs'')
                      else exhaust req''' (out' <> kVs'')
                 in do
                  trace l' \_-> "trying via sub"
                  exhaust req' out
              xs -> do
                trace l' \_-> "failed to match: " <> pretty xs
                fail "... (no sub)"

  _lmap f (a /\ b /\ c) = f a /\ b /\ c

  _toElem :: Arg -> ArgParseLayout
  _toElem x =
    -- note: we know it's not fixed since we only use this function
    -- to re-inject options for `opts.repeatableOptions`.
    let isFree = true
     in ParseElem (Arg.getId x) isFree x

  _isRepeatable :: Arg -> Boolean
  _isRepeatable x = Arg.isArgRepeatable x || (repOpts && Arg.isOption x)

  {-
    Try to make a match from any of the input layouts.
    This parser deals with subsituting values, culling optional args and ensures
    order is maintained in lax-placement mode.
  -}
  match
    :: Int -- the recursive level
    -> Boolean -- allow substitutions?
    -> List ArgParseLayout
    -> ArgParser r (Tuple (Tuple
        (List KeyValue)        -- the key-value pairs that where yielded
        (List ArgParseLayout)) -- the layouts that did *NOT* match
        Boolean)               -- has this changed the input?
  match l sub xs = go' false xs Nil
    where
    go' locked (x:xs) ys = (do
      trace l \_-> "match"
        <> " x = " <> pretty x
        <> ", xs = " <> pretty xs
        <> ", ys = " <> pretty ys
        <> ", locked = " <> show locked
        <> ", sub = " <> show sub
      if _isFixed x && locked
        then go' true xs (x:ys)
        else do
          vs <- try $ parseLayout (l + 1) (sub && not locked) x
          trace l \_-> "match made!"
            <> " x = " <> pretty x
            <> ", xs = " <> pretty xs
            <> ", ys = " <> pretty ys
            <> ", vs = " <> pretty vs
            <> ", locked = " <> show locked
            <> ", sub = " <> show sub
          pure (vs /\ (sortBy (compare `on` getId) $ xs <> ys) /\ locked)
    ) `catch` \_ e -> do
      go' (locked || _isFixed x) xs (x:ys)

    {-
      Evaluate the result. We've tried all `req` items agains the same input
      now and none of them managed to make a match. Since all of these items
      are "free", substituting or removing one of them is not going to make abs
      difference for the others.
    -}
    go' locked Nil ys = do
      i <- getInput
      let ys' = sortBy (compare `on` getId) ys
      ys'' /\ changed <- pure do
       if locked
        then dropFirst (\x -> _isOptional x && _isFixed x) ys'
        else ys' /\ false

      trace l \_-> "match eval"
          <> " ys = " <> pretty ys
          <> ", ys' = " <> pretty ys'
          <> ", ys'' = " <> pretty ys''
          <> ", locked = " <> show locked
          <> ", sub = " <> show sub

      case if sub then filter (not <<< _isOptional) ys'' else ys'' of
        Nil -> do
          trace l \_-> "match succeeded!"

          -- substitute all leaf elements. we ignore groups because these groups
          -- have failed to parse irrespective of substitution, so they are a
          -- not considered a legible match.
          let subVs = catMaybes $ ys'' <#> case _ of
                        e@(ParseElem _ _ x) -> do
                          v <- Arg.getFallback x
                          pure (e /\ x /\ v)
                        _ -> Nothing

          -- return as a triplet, the values (only fallbacks), the layouts
          -- that where responsible for the values and finally if either have
          -- been locked (which indicates a possible change in input) or if
          -- we noticed a change during `dropFirst` (also releated to locking /
          -- positionals)
          pure ((_rest <$> subVs) /\ (_fst <$> subVs) /\ (locked || changed))
        zs | changed -> go' false zs Nil
        z:zs -> do
          trace l \_-> "match failed!"
          i <- getInput
          { depth } <- getState
          case i of
            Nil ->
              let c = toSimpleBranch (z:zs)
                  e = missingArgumentsError (unsafePartial $ NonEmpty.fromList' c)
               in setErrorAtDepth depth e *> fail' e
            _ -> do
              kToks <- for i \(pTok@(PositionedToken tok _ _)) -> do
                isKnown <- isKnownToken' tok
                pure if isKnown
                  then known pTok
                  else unknown pTok
              let e = unexpectedInputError (toSimpleBranch zs) kToks
              setErrorAtDepth depth e *> fail' e

  dropFirst f xs = go' xs Nil
    where go' Nil out = out /\ false
          go' (x:xs) out = if f x then (out <> xs) /\ true else go' xs (x:out)

  _fst  (a /\ b /\ c) = a
  _rest (a /\ b /\ c) = b /\ c

  _isFixed :: ArgParseLayout -> Boolean
  _isFixed (ParseGroup _ f _ _ _) = not f
  _isFixed (ParseElem _ f _) = not f

  _hasFallback :: ArgParseLayout -> Boolean
  _hasFallback (ParseElem _ _ x) = isJust (Arg.getFallback x)
  _hasFallback _ = false

  _isOptional :: ArgParseLayout -> Boolean
  _isOptional (ParseGroup _ _ o _ _) = o
  _isOptional (ParseElem _ _ x) = Arg.isOptional x

byOrigin :: List KeyValue -> Int
byOrigin vs = sum $ (Origin.weight <<< _.origin <<< unRichValue <<< snd) <$> vs

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

parseLayout
  :: ∀ r
   . Int
  -> Boolean
  -> ArgParseLayout
  -> ArgParser r (List KeyValue)
parseLayout l sub x = do
  { options } <- getConfig
  go options x
  where
  go opts (g@(ParseGroup _ _ _ r branches)) =
    let parsers = NonEmpty.toList branches <#> \branch ->
                    let args = NonEmpty.toList branch
                     in parseBranch l sub args
        p = evalParsers byOrigin parsers
     in do
      vs <- p
      if r && any (isFrom Origin.Argv <<< snd) vs
        then loop p vs
        else pure vs

     where
     loop p acc = do
        vs <- p <|> pure Nil
        if any (isFrom Origin.Argv <<< snd) vs
          then loop p (acc <> vs)
          else pure (acc <> vs)

  go opts (ParseElem _ _ x) =
    let arg = Arg.getArg x
        fromArgv = do
          RichValue.from Origin.Argv <$> parseArg arg
          <* modifyDepth (_ + 1)
     in do
      if sub
        then singleton <<< Tuple x <$> case Arg.getFallback x of
              Just v -> fromArgv <|> pure v
              _      -> fromArgv
        else
          let nTimes = if Arg.isArgRepeatable x then some else liftM1 singleton
           in nTimes $ Tuple x <$> fromArgv

{-
  Parse a single argument. We do not substitute and ignore repetitions.
-}
parseArg
  :: ∀ r
   . SolvedLayoutArg
  -> ArgParser r Value
parseArg = go
  where
  go (Solved.Positional n _) = positional n n
  go (Solved.Command    n _) = command    n n
  go (Solved.Stdin         ) = stdin
  go (Solved.EOA           ) = eoa <|> (pure $ ArrayValue [])
  go (Solved.Option a  mA r) = do
    input       <- getInput
    { options } <- getConfig
    case input of
      (PositionedToken token _ _) : _
        | case token of
            LOpt _ _   -> true
            SOpt _ _ _ -> true
            _          -> false
        -> do
          aliases /\ def /\ env <- do
            description <- lookupDescription' a
            case description of
              (OptionDescription aliases' _ _ def' env') ->
                pure $ aliases' /\ def' /\ env'
              _ -> fail' $ internalError "invalid option description"
          let
            ns = NonEmpty.toList $ aliases <#> case _ of
                  OptionAlias.Short f -> Left  f
                  OptionAlias.Long  n -> Right n
            longAliases = mrights ns
            shortAliases = mlefts ns
            term = any (_ `elem` options.stopAt) $ aliases <#> case _ of
                      OptionAlias.Short s -> "-"  <> String.singleton s
                      OptionAlias.Long  n -> "--" <> n

          -- note: safe to be unsafe because of pattern match above
          OptRes v canTerm canRepeat <- unsafePartial case token of
            LOpt _ _ ->
              case longAliases of
                Nil -> fail "Option has no long alias"
                _   -> choice $ longAliases <#> \alias -> try do
                        longOption term alias mA
            SOpt _ _ _ ->
              case shortAliases of
                Nil -> fail "Option has no short alias"
                _   -> choice $ shortAliases <#> \alias -> try do
                        shortOption term alias mA

          -- try terminating at this option
          if term && canTerm
              then do
                vs <- fail "not implemented" -- TODO: terminate x
                pure (ArrayValue (Value.intoArray v <> Value.intoArray vs))
              else do
                if isJust mA && r && canRepeat
                    then do
                      vs <- Array.many optionArgument
                      pure (ArrayValue (Value.intoArray v <> vs))
                    else pure v
      _ -> fail "Expected long or short option"

{-
  Convert an ordinary layout to a layout suitable for parsing. Each layout and
  element get their own unique id in a shared namespace. For example:
    `G0(E1, G2(E3))`
      where `G` denotes a Group and `E` denotes an element.
  Further, we determine up-front which layout is "free" and which one is "fixed",
  saving us unncessary traversals during the hot phase of the parse.
-}
toParseBranch
  :: List ArgLayout
  -> List ArgParseLayout
toParseBranch xs = evalState (for xs go) 0
  where
  nextId = State.get <* State.modify (_ + 1)
  go (e@(Elem x)) = do
    i <- nextId
    pure (ParseElem i (Arg.isFreeLayout e) (Arg.setId i x))
  go (g@(Group o r xs)) = do
    i <- nextId
    ParseGroup i (Arg.isFreeLayout g) o r <$> do
      for xs (traverse go)

toSimpleBranch
  :: List ArgParseLayout
  -> List SolvedLayout
toSimpleBranch Nil = Nil
toSimpleBranch (x:xs) = go x : toSimpleBranch xs
  where
  go (ParseElem _ _ x) = Elem $ Arg.getArg x
  go (ParseGroup _ _ o r xs) = Group o r $ (go <$> _) <$> xs

{-
  Convert an ordinary branch of solved arguments into a branch of `Arg`s.
  We perform this step to cache some information right along-side each argument,
  such as it's `ArgKey` and fallback value. This is going to save us from doing
  this during the hot phase of the parse.

  note: we set all `id`s to 0 and copy them later from the containing layout's
        `id`s. this allows us to cache on the arg and layout level, and to
        associate across the two.
-}
toArgBranch
  :: ∀ r
   . Options r
  -> Env
  -> List Description
  -> Branch SolvedLayoutArg
  -> Branch Arg
toArgBranch options env descriptions x = go <$> x
  where
  go (Elem x) =
    let description = case x of
          (Option alias _ _) -> findDescription alias descriptions
          _                  -> Nothing
        fallback = do
          v <- unRichValue <$> getFallbackValue options env description x
          pure $ RichValue v {
            value = if Solved.isElemRepeatable x
                      then ArrayValue $ Value.intoArray v.value
                      else v.value
          }
     in Elem $ Arg 0 x (toArgKey x) fallback false
  -- note: uncomment to collapse [-a] into an optional -a
  -- go (Group o r (((e@(Elem _)):|Nil):|Nil))
  --   = let e' = go e
  --      in unsafePartial $ case e' of
  --         Elem (Arg i x k mV o') ->
  --           Elem $ Arg i (Solved.setElemRepeatable r x) k mV (o || o')
  go (Group o r xs) = Group o r $ (go <$> _) <$> xs

isKnownToken'
  :: ∀ r
   . Token
  -> ArgParser r Boolean
isKnownToken' tok = do
  { spec } <- getConfig
  { isKnownCache } <- getGlobalState
  case Map.lookup tok isKnownCache of
    Just b -> pure b
    Nothing ->
      let isKnown = isKnownToken spec tok
       in isKnown <$ modifyGlobalState \s -> s {
            isKnownCache = Map.alter (const (Just isKnown)) tok s.isKnownCache
          }

{-
  Determine if a given token is considered known
-}
isKnownToken
  :: Spec SolvedLayout
  -> Token
  -> Boolean
isKnownToken (Spec { layouts, descriptions }) tok = occuresInDescs || occuresInLayouts
  where
  occuresInDescs = any matchesDesc descriptions
    where
    matchesDesc (OptionDescription as _ _ _ _) = test tok
      where
      test (Token.LOpt n _)   = elem (OptionAlias.Long n) as
      test (Token.SOpt s _ _) = elem (OptionAlias.Short s) as
      test _ = false
    matchesDesc _ = false
  occuresInLayouts = any (any (any matchesLayout)) layouts
    where
    matchesLayout (Group _ _ xs) = any (any matchesLayout) xs
    matchesLayout (Elem x) = test tok x
      where
      test (Token.LOpt n _)   (Solved.Option a _ _) = OptionAlias.Long n == a
      test (Token.SOpt s _ _) (Solved.Option a _ _) = OptionAlias.Short s == a
      test (Token.Lit n)      (Solved.Command n' _) = n == n'
      test (Token.EOA _)      (Solved.EOA)          = true
      test (Token.Stdin)      (Solved.Stdin)        = true
      test _ _ = false


Tidy up

Tidy up

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Either

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a b r. (b -> a -> Either b r) -> b -> ContRef eff a -> ContRef eff r
foldC f b0 c = do
  current <- lift $ newRef b0
  callCC $ \k -> quietly $ do
    a <- c
    b <- lift $ readRef current
    case f b a of
      Left next -> lift $ writeRef current next
      Right r -> k r

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Right xs
  f xs (Just x) = Left (xs ++ [x])

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Either

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a b r. (b -> a -> Either b r) -> b -> ContRef eff a -> ContRef eff r
foldC f r0 c = do
  current <- lift $ newRef r0
  callCC $ \k -> quietly $ do
    a <- c
    b <- lift $ readRef current
    case f b a of
      Left next -> lift $ writeRef current next
      Right r -> k r

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Right xs
  f xs (Just x) = Left (xs ++ [x])


Remove mandatory "renderer" key from BDTrack

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Foreign (Foreign, toForeign)

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Foreign (Foreign, toForeign)

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String, renderer :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)