Update comments for `ComponentSpec`, etc

module Halogen.Component
  ( Component
  , ComponentSpec
  , component
  , ComponentSpec'
  , component'
  , unComponent
  , hoist
  , ComponentSlot'
  , ComponentSlot
  , mkComponentSlot
  , mkComponentSlot'
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM')
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra; the requests that can be made of the component
-- | - `i` is the input value that will be received when the parent of
-- |       this component renders
-- | - `o` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
data Component (h :: Type -> Type -> Type) (f :: Type -> Type) i o (m :: Type -> Type)

-- | The spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra; the requests that can be made of the component
-- | - `ps` is the set of slots for addressing child components
-- | - `i` is the input value that will be received when the parent of
-- |       this component renders
-- | - `o` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
type ComponentSpec h s f ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m (f Unit)) (f Unit)
  , eval :: f ~> HalogenM' s (f Unit) ps o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component from a `ComponentSpec`.
component
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> Component h f i o m
component = component' <<< go
  where
    go :: ComponentSpec h s f ps i o m -> ComponentSpec' h s f (f Unit) ps i o m
    go spec =
      { initialState: spec.initialState
      , render: spec.render
      , eval: case _ of
          Initialize a -> traverse_ spec.eval spec.initializer $> a
          Finalize a -> traverse_ spec.eval spec.finalizer $> a
          Receive i a -> traverse_ spec.eval (spec.receiver i) $> a
          Handle fa a -> spec.eval fa $> a
          Request fa -> spec.eval fa
      }

-- | An alternative formulation of the spec for a component.
-- |
-- | Instead of accepting a number of properties that map things to queries,
-- | these cases are instead handled by pattern matching on a `HalogenQ` algebra
-- | that `eval` takes as an argument.
-- |
-- | Components defined with this spec can also separate the public query
-- | algebra for requests from actions that can be handled internally. The other
-- | spec formulation requires these actions to be of type `f Unit`, so in that
-- | case the query algebra must also contain the actions the component can
-- | raise internally.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra; the requests that can be made of the component
-- | - `act` is the type of actions; messages internal to the component that
-- |         can be evaluated
-- | - `ps` is the set of slots for addressing child components
-- | - `i` is the input value that will be received when the parent of
-- |       this component renders
-- | - `o` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
type ComponentSpec' h s f act ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m act) act
  , eval :: HalogenQ f act i ~> HalogenM' s act ps o m
  }

-- | Builds a component from a `ComponentSpec'`.
component'
  :: forall h s f g ps i o m
   . ComponentSpec' h s f g ps i o m
  -> Component h f i o m
component' = unsafeCoerce

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The hidden details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem if
-- | this is attempted.
unComponent
  :: forall h f i o m r
   . (forall s act ps. ComponentSpec' h s f act ps i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat = unComponent \c ->
  component'
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

--------------------------------------------------------------------------------

type ComponentSlot' h f i o ps m a =
  { get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  , pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  , set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  , component :: Component h f i o m
  , input :: forall act. HalogenQ f act i Unit
  , output :: o -> Maybe a
  }

data ComponentSlot (h :: Type -> Type -> Type) (ps :: # Type) (m :: Type -> Type) a

instance functorComponentSlot :: Functor (ComponentSlot h ps m) where
  map f = unComponentSlot \slot -> mkComponentSlot' $ slot { output = map f <$> slot.output }

mkComponentSlot
  :: forall h sym px ps f i o p m a
   . Row.Cons sym (Slot f o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component h f i o m
  -> i
  -> (o -> Maybe a)
  -> ComponentSlot h ps m a
mkComponentSlot sym p comp input output =
  mkComponentSlot' { get, pop, set, component: comp, input: Receive input unit, output }
  where
  get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  get = Slot.lookup sym p

  pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  pop = Slot.pop sym p

  set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  set = Slot.insert sym p

mkComponentSlot'
  :: forall h f i o ps m a
   . ComponentSlot' h f i o ps m a
  -> ComponentSlot h ps m a
mkComponentSlot' = unsafeCoerce

unComponentSlot
  :: forall h ps m a r
   . (forall f i o. ComponentSlot' h f i o ps m a -> r)
  -> ComponentSlot h ps m a
  -> r
unComponentSlot = unsafeCoerce

hoistSlot
  :: forall h m m' ps a
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> ComponentSlot h ps m a
  -> ComponentSlot h ps m' a
hoistSlot nat = unComponentSlot \slot ->
  mkComponentSlot' $ slot { component = hoist nat slot.component }

module Halogen.Component
  ( Component
  , ComponentSpec'
  , ComponentSpec
  , component'
  , component
  , unComponent
  , hoist
  , ComponentSlot'
  , ComponentSlot
  , mkComponentSlot
  , mkComponentSlot'
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM')
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
data Component (h :: Type -> Type -> Type) (f :: Type -> Type) i o (m :: Type -> Type)

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The inner details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem.
unComponent
  :: forall h f i o m r
   . (forall s act ps. ComponentSpec' h s f act ps i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

type ComponentSpec' h s f act ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m act) act
  , eval :: HalogenQ f act i ~> HalogenM' s act ps o m
  }

-- | The spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `ps` is the set of slots for addressing child components
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ComponentSpec h s f ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m (f Unit)) (f Unit)
  , eval :: f ~> HalogenM' s (f Unit) ps o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

specToSpec
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> ComponentSpec' h s f (f Unit) ps i o m
specToSpec spec =
  { initialState: spec.initialState
  , render: spec.render
  , eval: case _ of
      Initialize a -> traverse_ spec.eval spec.initializer $> a
      Finalize a -> traverse_ spec.eval spec.finalizer $> a
      Receive i a -> traverse_ spec.eval (spec.receiver i) $> a
      Handle fa a -> spec.eval fa $> a
      Request fa -> spec.eval fa
  }

component'
  :: forall h s f g ps i o m
   . ComponentSpec' h s f g ps i o m
  -> Component h f i o m
component' = unsafeCoerce

-- | Builds a component that allows for children.
component
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> Component h f i o m
component = component' <<< specToSpec

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat = unComponent \c ->
  component'
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

--------------------------------------------------------------------------------

type ComponentSlot' h f i o ps m a =
  { get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  , pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  , set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  , component :: Component h f i o m
  , input :: forall act. HalogenQ f act i Unit
  , output :: o -> Maybe a
  }

data ComponentSlot (h :: Type -> Type -> Type) (ps :: # Type) (m :: Type -> Type) a

instance functorComponentSlot :: Functor (ComponentSlot h ps m) where
  map f = unComponentSlot \slot -> mkComponentSlot' $ slot { output = map f <$> slot.output }

mkComponentSlot
  :: forall h sym px ps f i o p m a
   . Row.Cons sym (Slot f o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component h f i o m
  -> i
  -> (o -> Maybe a)
  -> ComponentSlot h ps m a
mkComponentSlot sym p comp input output =
  mkComponentSlot' { get, pop, set, component: comp, input: Receive input unit, output }
  where
  get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  get = Slot.lookup sym p

  pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  pop = Slot.pop sym p

  set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  set = Slot.insert sym p

mkComponentSlot'
  :: forall h f i o ps m a
   . ComponentSlot' h f i o ps m a
  -> ComponentSlot h ps m a
mkComponentSlot' = unsafeCoerce

unComponentSlot
  :: forall h ps m a r
   . (forall f i o. ComponentSlot' h f i o ps m a -> r)
  -> ComponentSlot h ps m a
  -> r
unComponentSlot = unsafeCoerce

hoistSlot
  :: forall h m m' ps a
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> ComponentSlot h ps m a
  -> ComponentSlot h ps m' a
hoistSlot nat = unComponentSlot \slot ->
  mkComponentSlot' $ slot { component = hoist nat slot.component }


Retry with .cmd on windows

Retry with .cmd on windows

module Main where

import Prelude
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throw, throwException, message)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--psc=PSC] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , psc: "psc"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: Date.Now
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , psc
  , showSource
  , stash
  , stashFile
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (<> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' psc args \buffer -> do
    let stderr = Str.split "\n" buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          out' <- output loadLinesImpl opts' out { warnings = merged }
          when stash $ writeStashFile stashFile merged
          DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (<> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix ".cmd" cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> Date.now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date >) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))

module Main where

import Prelude (Unit, pure, bind, otherwise, void, show, flip, const, (<<<), (>>=), (<$>), (<>), (>), ($), (-), (||), (==))
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--psc=PSC] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , psc: "psc"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: Date.Now
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , psc
  , showSource
  , stash
  , stashFile
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (<> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  child <- Child.spawn psc (Array.cons "--json-errors" extra) Child.defaultSpawnOptions { stdio = stdio }
  buffer <- ST.newSTRef ""

  Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
    void $ ST.modifySTRef buffer (<> chunk)

  Child.onExit child \status ->
    case status of
      Child.Normally n -> do
        stderr <- Str.split "\n" <$> ST.readSTRef buffer
        for_ stderr \err ->
          case jsonParser err >>= decodeJson >>= parsePsaResult of
            Left _ -> Console.error err
            Right out -> do
              files <- STMap.new
              let loadLinesImpl = if showSource then loadLines files else loadNothing
                  filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
              merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
              out' <- output loadLinesImpl opts' out { warnings = merged }
              when stash $ writeStashFile stashFile merged
              DefaultPrinter.print opts' out'
              if StrMap.isEmpty out'.stats.allErrors
                then Process.exit 0
                else Process.exit 1
        Process.exit n

      Child.BySignal s -> do
        Console.error (show s)
        Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> Date.now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date >) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))


restore schedRef

restore schedRef

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Foldable (class Foldable, indexl, sequence_, traverse_)
import Data.Foreign (Foreign)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  schedRef <- newRef false
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use something like
      -- `setImmediate` and use `Ref Boolean` to make sure maximum one `notify` is
      -- scheduled per event loop.
      unlessM (readRef schedRef) do
        writeRef schedRef true
        unsafeSetImmediate $ do
          writeRef schedRef false
          notify =<< locationState

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- | Similar to `setImmediate`, it's impelemnted using microtask queue via MutationObserver
-- | to schedule callbacks. this way it's more imediate then `setTimout` would have been.
-- | We use a fresh counter so that the text change mutation always fires.
-- |
-- | NOTE: it's not that unsafe, but we use `unsafeRunRef` and `runPure` so it's still unsafe.
unsafeSetImmediate
  :: forall r
  . Eff (ref :: REF, dom :: DOM |r) Unit -> Eff (ref :: REF, dom :: DOM |r) Unit
unsafeSetImmediate =
  let
    freshRef = runPure $ unsafeRunRef $ newRef 0
    effRef = runPure $ unsafeRunRef $ newRef Nil
    nodeRef = runPure $ unsafeRunRef $ newRef Nothing
  in \eff -> do
    modifyRef effRef $ Cons eff
    obsvNode <- readRef nodeRef >>= case _ of
      Nothing -> do
        obsvNode <-
          DOM.window
            >>= DOM.document
            >>> map DOM.htmlDocumentToDocument
            >>= DOM.createTextNode ""
            >>> map DOM.textToNode
        observer <- DOM.mutationObserver \_ _ -> do
          readRef effRef >>= sequence_
          writeRef effRef Nil
        DOM.observe obsvNode { characterData: true } observer
        pure obsvNode
      Just obsvNode ->
        pure obsvNode
    fresh ← readRef freshRef
    writeRef freshRef (fresh + 1)
    DOM.setNodeValue (show fresh) obsvNode

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Foldable (class Foldable, indexl, sequence_, traverse_)
import Data.Foreign (Foreign)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use the microtask
      -- queue via MutationObserver to schedule callbacks. Alternatively we could
      -- just use a setTimeout, but it would not be as prompt. We use a fresh
      -- counter so that the text change mutation always fires.
      unsafeSetImmediate $ notify =<< locationState

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- It's not that unsafe actually, but we use unsafeRunRef so it's still unsafe.
unsafeSetImmediate
  :: forall r
  . Eff (ref :: REF, dom :: DOM |r) Unit -> Eff (ref :: REF, dom :: DOM |r) Unit
unsafeSetImmediate =
  let
    freshRef = runPure $ unsafeRunRef $ newRef 0
    effRef = runPure $ unsafeRunRef $ newRef Nil
    nodeRef = runPure $ unsafeRunRef $ newRef Nothing
  in \eff -> do
    modifyRef effRef $ Cons eff
    obsvNode <- readRef nodeRef >>= case _ of
      Nothing -> do
        obsvNode <-
          DOM.window
            >>= DOM.document
            >>> map DOM.htmlDocumentToDocument
            >>= DOM.createTextNode ""
            >>> map DOM.textToNode
        observer <- DOM.mutationObserver \_ _ -> do
          readRef effRef >>= sequence_
          writeRef effRef Nil
        DOM.observe obsvNode { characterData: true } observer
        pure obsvNode
      Just obsvNode ->
        pure obsvNode
    fresh ← readRef freshRef
    writeRef freshRef (fresh + 1)
    DOM.setNodeValue (show fresh) obsvNode


Only add slam extension if necessary

Only add slam extension if necessary

{-
Copyright 2016 SlamData, Inc.

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

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

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

module Utils.Path
  ( module Utils.Path
  , module Quasar.Types
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array (intersect, null, (:))
import Data.Char as Ch
import Data.Either (Either(..), either, fromRight)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy (Sandboxed, Unsandboxed, Abs, Path, File, Rel, Dir, DirName(..), FileName(..), peel, rootDir, (</>), file, canonicalize, printPath, parseAbsDir, parseAbsFile, dir, relativeTo, renameDir)
import Data.Path.Pathy as P
import Data.String as S
import Data.String.Regex as Rgx
import Data.String.Regex.Flags as RXF
import Data.Tuple (snd, fst)

import Global as Global

import Quasar.Types (AnyPath, DirPath, FilePath)

import Partial.Unsafe (unsafePartial)

import SlamData.Config as Config

import Text.SlamSearch.Parser.Tokens (keyChars)

infixl 6 renameDirExt as <./>

newtype Extension = Extension String

renameDirExt :: forall a s. Path a Dir s -> String -> Path a Dir s
renameDirExt p ext = renameDir (changeDirExt $ const ext) p

addDirExt :: forall a s. String -> Path a Dir s -> Path a Dir s
addDirExt ext = renameDir \(DirName d) -> DirName $ dropExt (Extension ext) d <> "." <> ext

rootify :: DirPath -> Path Rel Dir Sandboxed
rootify p = fromMaybe (dir "/") $ relativeTo p rootDir

rootifyFile :: FilePath -> Path Rel File Sandboxed
rootifyFile p = fromMaybe (file "") $ relativeTo p rootDir

sandbox ∷ ∀ b. Path Abs b Unsandboxed → Maybe (Path Abs b Sandboxed)
sandbox = map (rootDir </> _) <<< P.sandbox rootDir

-- | Set by default to support cells without
-- | `pathToWorkspace` field. After first save `pathToWorkspace` is
-- | setted to correct workspace path.
phantomWorkspacePath :: DirPath
phantomWorkspacePath = rootDir </> dir "phantom" <./> Config.workspaceExtension

parseAnyPath :: String -> Maybe AnyPath
parseAnyPath s
  = Right <$> parseFilePath s
  <|> Left <$> parseDirPath s

parseFilePath :: String -> Maybe FilePath
parseFilePath s = (rootDir </> _) <$> (P.sandbox rootDir =<< parseAbsFile s)

parseDirPath :: String -> Maybe DirPath
parseDirPath s = (rootDir </> _) <$> (P.sandbox rootDir =<< parseAbsDir s)

changeDirExt :: (String -> String) -> DirName -> DirName
changeDirExt f (DirName name) =
  DirName ((if ext == "" then name else n) <> "." <> f ext)
  where
  mbIdx = S.lastIndexOf (S.Pattern ".") name
  n = maybe name (\idx -> S.take idx name) mbIdx
  ext = maybe "" (\idx -> S.drop (idx + 1) name) mbIdx

dropDirExt :: DirName -> DirName
dropDirExt (DirName d) =
  DirName $ maybe d (\idx -> S.take idx d) $ S.lastIndexOf (S.Pattern ".") d

takeDirExt :: DirName -> String
takeDirExt (DirName d) =
  maybe "" (\idx -> S.drop (idx + 1) d) $ S.lastIndexOf (S.Pattern ".") d

dropExt ∷ Extension → String → String
dropExt (Extension ext) name =
  fromMaybe name do
    idx ← S.lastIndexOf (S.Pattern ".") name
    if S.drop (idx + 1) name == ext
      then pure $ S.take idx name
      else Nothing

dropWorkspaceExt :: String -> String
dropWorkspaceExt = dropExt (Extension Config.workspaceExtension)

decodeURIPath :: String -> String
decodeURIPath uri =
  Global.decodeURIComponent $
    Rgx.replace (unsafePartial fromRight $ Rgx.regex "\\+" RXF.global) " " uri

encodeURIPath :: String -> String
encodeURIPath path =
  S.joinWith "/" $
  S.joinWith "+" <$>
  (Global.encodeURIComponent <$> _) <$>
  S.split (S.Pattern " ") <$>
  S.split (S.Pattern "/") path

hidePath :: String -> String -> String
hidePath path input =
  S.trim $
  S.replace (S.Pattern $ "+path:\"" <> path <> "\"") (S.Replacement "") $
  S.replace (S.Pattern $ "+path:" <> path) (S.Replacement "") input

renderPath :: AnyPath -> String
renderPath ap =
  if null $ intersect (S.toCharArray rendered) ((Ch.fromCharCode 32):keyChars)
  then rendered
  else "\"" <> rendered <> "\""
  where
  rendered = either renderDir renderFile ap
  renderDir path =
    printPath $ canonicalize $ maybe rootDir (rootDir </> _) (P.sandbox rootDir path)

  renderFile path =
    printPath $ canonicalize $
    maybe (rootDir </> file "") (rootDir </> _) (P.sandbox rootDir path)

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' = maybe rootDir fst <<< peel

rootFile ∷ FilePath
rootFile = rootDir </> file ""

{-
Copyright 2016 SlamData, Inc.

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

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

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

module Utils.Path
  ( module Utils.Path
  , module Quasar.Types
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array (intersect, null, (:))
import Data.Char as Ch
import Data.Either (Either(..), either, fromRight)
import Data.Maybe (Maybe, maybe, fromMaybe)
import Data.Path.Pathy (Sandboxed, Unsandboxed, Abs, Path, File, Rel, Dir, DirName(..), FileName(..), peel, rootDir, (</>), file, canonicalize, printPath, parseAbsDir, parseAbsFile, dir, relativeTo, renameDir)
import Data.Path.Pathy as P
import Data.String as S
import Data.String.Regex as Rgx
import Data.String.Regex.Flags as RXF
import Data.Tuple (snd, fst)

import Global as Global

import Quasar.Types (AnyPath, DirPath, FilePath)

import Partial.Unsafe (unsafePartial)

import SlamData.Config as Config

import Text.SlamSearch.Parser.Tokens (keyChars)

infixl 6 renameDirExt as <./>

renameDirExt :: forall a s. Path a Dir s -> String -> Path a Dir s
renameDirExt p ext = renameDir (changeDirExt $ const ext) p

addDirExt :: forall a s. String -> Path a Dir s -> Path a Dir s
addDirExt ext = renameDir (\(DirName d) -> DirName $ d <> "." <> ext)

rootify :: DirPath -> Path Rel Dir Sandboxed
rootify p = fromMaybe (dir "/") $ relativeTo p rootDir

rootifyFile :: FilePath -> Path Rel File Sandboxed
rootifyFile p = fromMaybe (file "") $ relativeTo p rootDir

sandbox ∷ ∀ b. Path Abs b Unsandboxed → Maybe (Path Abs b Sandboxed)
sandbox = map (rootDir </> _) <<< P.sandbox rootDir

-- | Set by default to support cells without
-- | `pathToWorkspace` field. After first save `pathToWorkspace` is
-- | setted to correct workspace path.
phantomWorkspacePath :: DirPath
phantomWorkspacePath = rootDir </> dir "phantom" <./> Config.workspaceExtension

parseAnyPath :: String -> Maybe AnyPath
parseAnyPath s
  = Right <$> parseFilePath s
  <|> Left <$> parseDirPath s

parseFilePath :: String -> Maybe FilePath
parseFilePath s = (rootDir </> _) <$> (P.sandbox rootDir =<< parseAbsFile s)

parseDirPath :: String -> Maybe DirPath
parseDirPath s = (rootDir </> _) <$> (P.sandbox rootDir =<< parseAbsDir s)

changeDirExt :: (String -> String) -> DirName -> DirName
changeDirExt f (DirName name) =
  DirName ((if ext == "" then name else n) <> "." <> f ext)
  where
  mbIdx = S.lastIndexOf (S.Pattern ".") name
  n = maybe name (\idx -> S.take idx name) mbIdx
  ext = maybe "" (\idx -> S.drop (idx + 1) name) mbIdx

dropDirExt :: DirName -> DirName
dropDirExt (DirName d) =
  DirName $ maybe d (\idx -> S.take idx d) $ S.lastIndexOf (S.Pattern ".") d

takeDirExt :: DirName -> String
takeDirExt (DirName d) =
  maybe "" (\idx -> S.drop (idx + 1) d) $ S.lastIndexOf (S.Pattern ".") d

dropWorkspaceExt :: String -> String
dropWorkspaceExt name = S.take (S.length name - S.length Config.workspaceExtension - 1) name

decodeURIPath :: String -> String
decodeURIPath uri =
  Global.decodeURIComponent $
    Rgx.replace (unsafePartial fromRight $ Rgx.regex "\\+" RXF.global) " " uri

encodeURIPath :: String -> String
encodeURIPath path =
  S.joinWith "/" $
  S.joinWith "+" <$>
  (Global.encodeURIComponent <$> _) <$>
  S.split (S.Pattern " ") <$>
  S.split (S.Pattern "/") path

hidePath :: String -> String -> String
hidePath path input =
  S.trim $
  S.replace (S.Pattern $ "+path:\"" <> path <> "\"") (S.Replacement "") $
  S.replace (S.Pattern $ "+path:" <> path) (S.Replacement "") input

renderPath :: AnyPath -> String
renderPath ap =
  if null $ intersect (S.toCharArray rendered) ((Ch.fromCharCode 32):keyChars)
  then rendered
  else "\"" <> rendered <> "\""
  where
  rendered = either renderDir renderFile ap
  renderDir path =
    printPath $ canonicalize $ maybe rootDir (rootDir </> _) (P.sandbox rootDir path)

  renderFile path =
    printPath $ canonicalize $
    maybe (rootDir </> file "") (rootDir </> _) (P.sandbox rootDir path)

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' = maybe rootDir fst <<< peel

rootFile ∷ FilePath
rootFile = rootDir </> file ""


Fix broken Eff action

Fix broken Eff action

module VirtualDOM
  ( PatchObject()
  , createElement
  , diff
  , patch
  ) where

import Control.Monad.Eff
import Data.Function
import DOM
import VirtualDOM.VTree

foreign import data PatchObject :: *

foreign import showPatchObjectImpl
  "var showPatchObjectImpl = JSON.stringify;" :: PatchObject -> String

instance showPatchObject :: Show PatchObject where
  show = showPatchObjectImpl

foreign import createElement
  "var createElement = require('virtual-dom/create-element');" :: VTree -> Node

foreign import diff'
  "var diff$prime = require('virtual-dom/diff');" :: Fn2 VTree VTree PatchObject

diff :: VTree -> VTree -> PatchObject
diff = runFn2 diff'

foreign import patch'
  "var patch$prime = require('virtual-dom/patch');" :: Fn2 Node PatchObject Node

patch :: forall e. PatchObject -> Node -> Eff (dom :: DOM | e) Node
patch p n = mkEff \_ -> runFn2 patch' n p

foreign import mkEff """
  function mkEff(action) {
    return action;
  }
  """ :: forall eff a. (Unit -> a) -> Eff eff a

module VirtualDOM
  ( PatchObject()
  , createElement
  , diff
  , patch
  ) where

import Control.Monad.Eff
import Data.Function
import DOM
import VirtualDOM.VTree

foreign import data PatchObject :: *

foreign import showPatchObjectImpl
  "var showPatchObjectImpl = JSON.stringify;" :: PatchObject -> String

instance showPatchObject :: Show PatchObject where
  show = showPatchObjectImpl

foreign import createElement
  "var createElement = require('virtual-dom/create-element');" :: VTree -> Node

foreign import diff'
  "var diff$prime = require('virtual-dom/diff');" :: Fn2 VTree VTree PatchObject

diff :: VTree -> VTree -> PatchObject
diff = runFn2 diff'

foreign import patch'
  "var patch$prime = require('virtual-dom/patch');" :: Fn2 Node PatchObject Node

patch :: forall e. PatchObject -> Node -> Eff (dom :: DOM | e) Node
patch p n = return $ runFn2 patch' n p


Refactor: Remove file that I accidentally checked in

Whoops, lel

data Attribute
  = Strength     -- Damage dealt; how much stock you can move/carry
  | Agility      -- Chance to hit; stealing success; task completion speed
  | Charisma     -- Trading success; spying entry (social engineering)
  | Perception   -- Counter-espionage; spying planning; scavenging

data Skill
  = Scavenge
  | Steal
  | Spy
  | Counterespionage
  | Trade

data Shop
  = Shop { isOpen :: Boolean }

data Item
  = WalkingCane

data Goon
  = Goon { ident :: Long, name :: String, attributes :: [(Attribute, Int)], skills :: [(Skill, Int)], inventory :: [Item] }

data Task
  = Task { ident :: Long, description :: String, assignees :: [Employee], progress :: Number, baseDuration :: Number }

data User
  = User { ident :: Long, shop :: Shop, taskQueue :: [Task] }


Remove unncessary code from SpecParser lexer

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (StateT())
import Control.MonadPlus (guard)
import Data.Either (Either(..))
import Data.Identity (Identity())
import Data.List (List(..), many, catMaybes, toUnfoldable)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | faster P.skipSpaces
-- | TODO: move
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m = flip P.runParser (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

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

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

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

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

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- L.many $ parsePositionedToken (parseToken m)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

parsePositionedToken :: (P.Parser String Token) -> P.Parser String PositionedToken
parsePositionedToken p = do
  pos <- getPosition
  tok <- p
  pure $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ P.try _tag ] else []
  , [ P.try _reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , P.string "..." *> pure TripleDot
    , P.try _longOption
    , P.try _shortOption
    , P.try _eoa
    , P.try _stdin
    , P.try $ AngleName <$> _angleName
    , P.try $ ShoutName <$> _shoutName
    , P.try $ Name      <$> _name
    ]
  , if isDescMode m
        then [
          P.try $ eol      $> Newline
        , P.try $ Garbage <$> P.anyChar
        ]
        else []
  ])
  <* if isDescMode m
        then void $ spaces -- skip only spaces ' ' and '\t'
        else skipSpaces  -- skip spaces *AND* newlines

 where

  white :: P.Parser String Unit
  white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

  _stdin :: P.Parser String Token
  _stdin = do
    P.char '-'
    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char '|'
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.string "..."
    ])
    pure Dash

  _eoa :: P.Parser String Token
  _eoa = do
    P.string "--"
    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char ']'
    , void $ P.char ')'
    ])
    pure DoubleDash

  _reference :: P.Parser String Token
  _reference = Reference <$> do
    P.between (P.char '[') (P.char ']') go

    where
      go = do
        many space
        fromCharArray <<< toUnfoldable <$> do
          flip P.manyTill (P.lookAhead end) do
            P.noneOf [ ']' ]
        <* end <* skipSpaces

      end = do
        many space
        P.optional $ P.string "-"
        string' "options"
        P.optional $ P.string "..."

  _tag :: P.Parser String Token
  _tag = P.between (P.char '[') (P.char ']') do
    P.choice $ P.try <$> [
      withValue
    , withoutValue
    ]

    where
      withValue = do
        many white
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many white
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many white
        pure (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        pure (Tag k Nothing)

  _shoutName :: P.Parser String String
  _shoutName = do
    n <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many (upperAlpha <|> P.oneOf ['-', '_']))
    P.notFollowedBy lowerAlpha
    pure n

  _name :: P.Parser String String
  _name = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    pure $ fromCharArray (n A.: ns)

  _angleName :: P.Parser String String
  _angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
        -- disallow swallowing new `<`s in order to avoid creating hard to trace
        -- errors for the user
      , P.try $ P.noneOf [ '<', '>' ]
      ]
    P.char '>'
    pure $ "<" <> n <> ">"

  _shortOption :: P.Parser String Token
  _shortOption = do
    let validChar = alphaNum <|> P.oneOf [ '?' ]

    P.char '-'
    x  <- validChar
    xs <- A.many validChar

    arg <- P.choice $ P.try <$> [

      -- Case 1: -foo=BAR
      Just <$> do
        P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        pure  { name:     n
              , optional: false
              }

      -- Case 2: Option[=ARG]
    , Just <$> do
        P.char '['
        P.optional $ P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        P.char ']'
        pure  { name:     n
              , optional: true
              }

      -- Case 3: Option<ARG>
    , Just <$> do
        n <- _angleName
        pure { name:     n
              , optional: false
              }

    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ [
      void $ white
    , void $ P.char '|'
    , void $ P.string "..."
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.char ',' -- desc mode only
    ])

    pure $ SOpt x xs arg

  _longOption :: P.Parser String Token
  _longOption = do
    P.string "--"

    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION=ARG
      Just <$> do
        P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        pure { name:     n
               , optional: false
               }

      -- Case 2: Option[=ARG]
    , Just <$> do
        P.char '['
        P.optional $ P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        P.char ']'
        pure { name:     n
               , optional: true
               }

    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ [
      void $ white
    , void $ P.char '|'
    , void $ P.string "..."
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.char ',' -- desc mode only
    ])

    pure $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
                case xs of
                  Cons (PositionedToken { sourcePos: npos }) _ -> npos
                  Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: P.ParserT (List PositionedToken)
                      (StateT { indentation :: Int , line :: Int } Identity )
                      Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (StateT())
import Control.MonadPlus (guard)
import Data.Either (Either(..))
import Data.Identity (Identity())
import Data.List (List(..), many, catMaybes, toUnfoldable)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf) as P

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m = flip P.runParser (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

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

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

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

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

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  P.skipSpaces
  xs <- L.many $ parsePositionedToken m
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

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

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ _tag ] else []
  , [ _reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , P.string "..." *> pure TripleDot
    , _longOption
    , _shortOption
    , _eoa
    , _stdin
    , AngleName <$> _angleName
    , ShoutName <$> _shoutName
    , Name      <$> _name
    ]
  , if isDescMode m
        then [
          eol      $> Newline
        , Garbage <$> P.anyChar
        ]
        else []
  ])
  <* if isDescMode m
        then void $ spaces -- skip only spaces ' ' and '\t'
        else P.skipSpaces  -- skip spaces *AND* newlines

 where

  white :: P.Parser String Unit
  white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

  _stdin :: P.Parser String Token
  _stdin = do
    P.char '-'
    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char '|'
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.string "..."
    ])
    pure Dash

  _eoa :: P.Parser String Token
  _eoa = do
    P.string "--"
    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char ']'
    , void $ P.char ')'
    ])
    pure DoubleDash

  _reference :: P.Parser String Token
  _reference = Reference <$> do
    P.between (P.char '[') (P.char ']') go

    where
      go = do
        many space
        fromCharArray <<< toUnfoldable <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [ ']' ]
        <* end <* many space

      end = do
        many space
        P.optional $ P.string "-"
        string' "options"
        P.optional $ P.string "..."

  _tag :: P.Parser String Token
  _tag = P.between (P.char '[') (P.char ']') do
    P.choice $ P.try <$> [
      withValue
    , withoutValue
    ]

    where
      withValue = do
        many white
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many white
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many white
        pure (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        pure (Tag k Nothing)

  _shoutName :: P.Parser String String
  _shoutName = do
    n <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many (upperAlpha <|> P.oneOf ['-', '_']))
    P.notFollowedBy lowerAlpha
    pure n

  _name :: P.Parser String String
  _name = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    pure $ fromCharArray (n A.: ns)

  _angleName :: P.Parser String String
  _angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
        -- disallow swallowing new `<`s in order to avoid creating hard to trace
        -- errors for the user
      , P.try $ P.noneOf [ '<', '>' ]
      ]
    P.char '>'
    pure $ "<" <> n <> ">"

  _shortOption :: P.Parser String Token
  _shortOption = do
    let validChar = alphaNum <|> P.oneOf [ '?' ]

    P.char '-'
    x  <- validChar
    xs <- A.many validChar

    arg <- P.choice $ P.try <$> [

      -- Case 1: -foo=BAR
      Just <$> do
        P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        pure  { name:     n
              , optional: false
              }

      -- Case 2: Option[=ARG]
    , Just <$> do
        P.char '['
        P.optional $ P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        P.char ']'
        pure  { name:     n
              , optional: true
              }

      -- Case 3: Option<ARG>
    , Just <$> do
        n <- _angleName
        pure { name:     n
              , optional: false
              }

    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char '|'
    , void $ P.string "..."
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.char ',' -- desc mode only
    ])

    pure $ SOpt x xs arg

  _longOption :: P.Parser String Token
  _longOption = do
    P.string "--"

    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION=ARG
      Just <$> do
        P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        pure { name:     n
               , optional: false
               }

      -- Case 2: Option[=ARG]
    , Just <$> do
        P.char '['
        P.optional $ P.char '='
        n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
        P.char ']'
        pure { name:     n
               , optional: true
               }

    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
      void $ white
    , void $ P.char '|'
    , void $ P.string "..."
    , void $ P.char ']'
    , void $ P.char ')'
    , void $ P.char ',' -- desc mode only
    ])

    pure $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
                case xs of
                  Cons (PositionedToken { sourcePos: npos }) _ -> npos
                  Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: P.ParserT (List PositionedToken)
                      (StateT { indentation :: Int , line :: Int } Identity )
                      Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })