mapMessage should be mapAction

mapMessage should be mapAction

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)

newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

newtype UnpackQuery ps g o f b =
  UnpackQuery (forall slot m. Applicative m => (slot g o -> m b) -> SlotStorage ps slot -> m (f b))

type QueryBox' ps g o a f b =
  { unpack :: UnpackQuery ps g o f b
  , query :: g b
  , reply :: f b -> a
  }

data QueryBox (ps :: # Type) a

mkQuery' :: forall ps g o a f b. QueryBox' ps g o a f b -> QueryBox ps a
mkQuery' = unsafeCoerce

unQuery :: forall ps a r. (forall g o f b. QueryBox' ps g o a f b -> r) -> QueryBox ps a -> r
unQuery = unsafeCoerce

-- | The Halogen component algebra
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | Halt String
  | ChildQuery (QueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (FF.Fork (HalogenM' s act ps o m) a)
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes a -> Subscribe fes (map f a)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery (unQuery (\cq' -> mkQuery' $ cq' { reply = cq'.reply >>> f }) cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

type HalogenM s act = HalogenM' s (act Unit)

instance functorHalogenM :: Functor (HalogenM' s act ps o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM' s act ps o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM' s act ps o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect eff = HalogenM $ liftF $ Lift $ liftEffect eff

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s act ps o m a. String -> HalogenM' s act ps o m a
halt msg = HalogenM $ liftF $ Halt msg

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.lookup sym p >>> traverse k
  , query: q
  , reply: identity
  }

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.slots sym >>> traverse k
  , query: q
  , reply: identity
  }

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

fork :: forall s act ps o m a. MonadAff m => HalogenM' s act ps o m a -> HalogenM' s act ps o m (Error -> m Unit)
fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapState f f') fo)
    GetRef p k -> GetRef p k

mapAction
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapAction f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe (map f <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapAction f)) p)
    Fork fo -> Fork (FF.hoistFork (mapAction f) fo)
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o  m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork fo -> Fork (FF.hoistFork (mapOutput f) fo)
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes a -> Subscribe (ES.hoist nat <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork fo -> Fork (FF.hoistFork (hoist nat) fo)
    GetRef p k -> GetRef p k

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)

newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

newtype UnpackQuery ps g o f b =
  UnpackQuery (forall slot m. Applicative m => (slot g o -> m b) -> SlotStorage ps slot -> m (f b))

type QueryBox' ps g o a f b =
  { unpack :: UnpackQuery ps g o f b
  , query :: g b
  , reply :: f b -> a
  }

data QueryBox (ps :: # Type) a

mkQuery' :: forall ps g o a f b. QueryBox' ps g o a f b -> QueryBox ps a
mkQuery' = unsafeCoerce

unQuery :: forall ps a r. (forall g o f b. QueryBox' ps g o a f b -> r) -> QueryBox ps a -> r
unQuery = unsafeCoerce

-- | The Halogen component algebra
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | Halt String
  | ChildQuery (QueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (FF.Fork (HalogenM' s act ps o m) a)
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes a -> Subscribe fes (map f a)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery (unQuery (\cq' -> mkQuery' $ cq' { reply = cq'.reply >>> f }) cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

type HalogenM s act = HalogenM' s (act Unit)

instance functorHalogenM :: Functor (HalogenM' s act ps o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM' s act ps o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM' s act ps o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect eff = HalogenM $ liftF $ Lift $ liftEffect eff

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s act ps o m a. String -> HalogenM' s act ps o m a
halt msg = HalogenM $ liftF $ Halt msg

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.lookup sym p >>> traverse k
  , query: q
  , reply: identity
  }

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.slots sym >>> traverse k
  , query: q
  , reply: identity
  }

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

fork :: forall s act ps o m a. MonadAff m => HalogenM' s act ps o m a -> HalogenM' s act ps o m (Error -> m Unit)
fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapState f f') fo)
    GetRef p k -> GetRef p k

mapMessage
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapMessage f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe (map f <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapMessage f)) p)
    Fork fo -> Fork (FF.hoistFork (mapMessage f) fo)
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o  m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork fo -> Fork (FF.hoistFork (mapOutput f) fo)
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes a -> Subscribe (ES.hoist nat <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork fo -> Fork (FF.hoistFork (hoist nat) fo)
    GetRef p k -> GetRef p k


Providing some string utility functions

Providing some string utility functions

module Main (main, slugify, stripMargin, stripMarginSimple) where

import Data.Foldable(Foldable, foldl)
import Data.String(toLower)
import Data.String.Regex(parseFlags, regex, Regex(..), replace)
import Data.Tuple(Tuple(..))

main = Debug.Trace.trace "hello"

slugify :: String -> String
slugify str = foldl foldFunc lowered replacements
  where
    lowered      = toLower str
    g            = parseFlags "g"
    replacements = [(Tuple (regex "['.,]" g) ""), (Tuple (regex " " g) "-")]
    foldFunc     = \acc (Tuple reg sub) -> replace reg sub acc

stripMargin :: String -> String -> String
stripMargin str delim = replace (regex r flags) "\n" str
  where
    flags = parseFlags "g"
    r     = "(?:^|\n[ \t]*)" ++ delim

stripMarginSimple :: String -> String
stripMarginSimple = flip stripMargin "\\|"

module Main where

main = Debug.Trace.trace "hello"


Distinct file dropping/selecting

Distinct file dropping/selecting

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , filesSelected
  , filesDropped
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())
import DOM.File.FileList as FileList

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | FilesSelected FileList a
  | FilesDropped FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

filesSelected :: ∀ a. FileList -> a -> Query a
filesSelected = FilesSelected

filesDropped :: ∀ a. FileList -> a -> Query a
filesDropped = FilesDropped

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  , files :: Maybe FileList
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , files: Nothing
  , options
  }

type Options
  = { view :: { dragover :: Boolean
              , multiple :: Boolean
              , files    :: Maybe FileList
              } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean, files :: Maybe FileList }
  -> ComponentHTML Query
defaultView { multiple, dragover, files } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        dropHandlers
        [ H.p_
            [ H.text if dragover
                     then "DROP IT!"
                     else "Or just drop it here"
            ]
        , H.p_
            [ H.text ("You selected " <> show (maybe 0 FileList.length files) <> " files") ]
        ]
    ]

dropHandlers :: ∀ r. Array (P.IProp r (Query Unit))
dropHandlers =
  [ E.onDragEnter
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragOver
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragExit
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver false)
  , E.onFilesDrop
      \files -> E.preventDefault
             *> E.stopPropagation
             $> action (filesDropped files)
  ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input filesSelected)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        , files: state.files
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  modify (_ { files = Just files })
  liftEff' $ logAny files
eval (FilesDropped files next) = next <$ do
  modify (_ { dragover = false })
eval (FilesSelected _ next) = pure next
eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , options
  }

type Options
  = { view :: { dragover :: Boolean, multiple :: Boolean } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean }
  -> ComponentHTML Query
defaultView { multiple, dragover } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        dropHandlers
        [ H.text if dragover
                 then "DROP IT!"
                 else "Or just drop it here"
        ]
    ]

dropHandlers :: ∀ r. Array (P.IProp r (Query Unit))
dropHandlers =
  [ E.onDragEnter
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragOver
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragExit
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver false)
  , E.onFilesDrop
      \files -> E.preventDefault
             *> E.stopPropagation
             $> action (setFiles files)
  ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input setFiles)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  modify (_ { dragover = false })
  liftEff' $ logAny files

eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })


Make MetricRenderer component compile

Make MetricRenderer component compile

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.MetricRenderer.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))
import SlamData.Workspace.Card.Port (MetricPort)

import Utils.DOM (fitText)

type State =
  { width ∷ Int
  , height ∷ Int
  , label ∷ Maybe String
  , value ∷ String
  , valueHeight ∷ Int
  , labelHeight ∷ Int
  }

initialState ∷ State
initialState =
  { width: 600
  , height: 400
  , label: Nothing
  , value: ""
  , valueHeight: 0
  , labelHeight: 0
  }

data Query a
  = SetMetric MetricPort a
  | SetDimensions {width ∷ Int, height ∷ Int} a
  | GetLOD (LevelOfDetails → a)

type DSL = H.ComponentDSL State Query Void Slam
type HTML = H.ComponentHTML Query

comp ∷ H.Component HH.HTML Query Unit Void Slam
comp =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "metric" ]
    , HP.ref refLabel
    ]
    [ HH.div
      [ HP.classes [ HH.ClassName "metric-value-and-label" ] ]
      $ [ HH.div
          [ HP.classes [ HH.ClassName "metric-value" ] ]
          [ HH.text state.value ] ]
          ⊕ foldMap renderLabel state.label
    ]
  where
  renderLabel ∷ String → Array HTML
  renderLabel str =
    [ HH.div
        [ HP.classes [ HH.ClassName "metric-label" ] ]
        [ HH.text str ]
    ]

eval ∷ Query ~> DSL
eval (SetMetric m next) = do
  H.modify _{label = m.label, value = m.value}
  adjustFontSizes
  pure next
eval (SetDimensions dims next) = do
  H.modify _{width = dims.width, height = dims.height}
  adjustFontSizes
  pure next
eval (GetLOD continue) = do
  state ← H.get
  pure $ continue $ if (state.labelHeight + state.valueHeight) > state.height then Low else High

availableFontSizes ∷ Array Int
availableFontSizes = [ 16, 24, 32, 48, 64, 96, 128, 160, 200 ]

adjustFontSizes ∷ DSL Unit
adjustFontSizes = do
  H.getHTMLElementRef refLabel >>= traverse_ \el →
    H.liftEff $ fitText availableFontSizes el

refLabel ∷ H.RefLabel
refLabel = H.RefLabel "container"

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.MetricRenderer.Component where

import SlamData.Prelude

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))
import SlamData.Workspace.Card.Port (MetricPort)

import Utils.DOM (fitText)

type State =
  { width ∷ Int
  , height ∷ Int
  , label ∷ Maybe String
  , value ∷ String
  , element ∷ Maybe HTMLElement
  , valueHeight ∷ Int
  , labelHeight ∷ Int
  }

initialState ∷ State
initialState =
  { width: 600
  , height: 400
  , label: Nothing
  , value: ""
  , element: Nothing
  , valueHeight: 0
  , labelHeight: 0
  }

data Query a
  = SetMetric MetricPort a
  | SetDimensions {width ∷ Int, height ∷ Int} a
  | GetLOD (LevelOfDetails → a)
  | SetElement (Maybe HTMLElement) a

type DSL = H.ComponentDSL State Query Slam
type HTML = H.ComponentHTML Query

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "metric" ]
    , HP.ref \el → H.action $ SetElement el
    ]
    [ HH.div
      [ HP.classes [ HH.ClassName "metric-value-and-label" ] ]
      $ [ HH.div
          [ HP.classes [ HH.ClassName "metric-value" ] ]
          [ HH.text state.value ] ]
          ⊕ foldMap renderLabel state.label
    ]
  where
  renderLabel ∷ String → Array HTML
  renderLabel str =
    [ HH.div
        [ HP.classes [ HH.ClassName "metric-label" ] ]
        [ HH.text str ]
    ]

eval ∷ Query ~> DSL
eval (SetMetric m next) = do
  H.modify _{label = m.label, value = m.value}
  adjustFontSizes
  pure next
eval (SetDimensions dims next) = do
  H.modify _{width = dims.width, height = dims.height}
  adjustFontSizes
  pure next
eval (GetLOD continue) = do
  state ← H.get
  pure $ continue $ if (state.labelHeight + state.valueHeight) > state.height then Low else High
eval (SetElement mbEl next) = do
  for_ mbEl \el → do
    H.modify _{element = Just el}
  pure next

availableFontSizes ∷ Array Int
availableFontSizes = [ 16, 24, 32, 48, 64, 96, 128, 160, 200 ]

adjustFontSizes ∷ DSL Unit
adjustFontSizes = do
  st ← H.get
  for_ st.element \vel → H.liftEff (fitText availableFontSizes vel)


Do not trim help output - fixes #71

Do not trim help output - fixes #71

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)
import Data.String (trim) as String
import Language.Docopt.Errors (developerErrorMessage)

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  program /\ action <- runEither do
    { program, specification, shortHelp, help } <- case input of
        (Left spec)   -> pure spec
        (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp program opts.helpFlags shortHelp)
      ((program /\ _) <<< case _ of
        output | canExit && output `has` opts.helpFlags    -> ShowHelp help
        output | canExit && output `has` opts.versionFlags -> ShowVersion
        output                                             -> Return output
      )
      (evalDocopt program specification env argv opts)

  case action of
    Return v      -> pure v
    ShowHelp help -> abort 0 help
    ShowVersion   -> do
      mVer <- maybe readPkgVersion (pure <<< pure) opts.version
      case mVer of
        Just ver -> abort 0 ver
        Nothing  -> abort 1
          $ program
              <> ": version not detected."
              <> "\n"
              <> developerErrorMessage
      abort 0 ""

  where
    has x = any (_ `member` x)
    canExit = not opts.dontExit

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort _ msg | opts.dontExit = throwException (error msg)
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure (abort 1)

    readPkgVersion = readPkgVersionImpl Just Nothing

    fmtHelp program helpFlags shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))
      <> if A.length helpFlags == 0
          then ""
          else "\n" <> "See "
                        <> program <> " " <> (intercalate "/" helpFlags)
                        <> " for more information"

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any, intercalate)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)
import Data.String (trim) as String
import Language.Docopt.Errors (developerErrorMessage)

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  program /\ action <- runEither do
    { program, specification, shortHelp, help } <- case input of
        (Left spec)   -> pure spec
        (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp program opts.helpFlags shortHelp)
      ((program /\ _) <<< case _ of
        output | canExit && output `has` opts.helpFlags    -> ShowHelp help
        output | canExit && output `has` opts.versionFlags -> ShowVersion
        output                                             -> Return output
      )
      (evalDocopt program specification env argv opts)

  case action of
    Return v      -> pure v
    ShowHelp help -> abort 0 (String.trim help)
    ShowVersion   -> do
      mVer <- maybe readPkgVersion (pure <<< pure) opts.version
      case mVer of
        Just ver -> abort 0 ver
        Nothing  -> abort 1
          $ program
              <> ": version not detected."
              <> "\n"
              <> developerErrorMessage
      abort 0 ""

  where
    has x = any (_ `member` x)
    canExit = not opts.dontExit

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort _ msg | opts.dontExit = throwException (error msg)
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure (abort 1)

    readPkgVersion = readPkgVersionImpl Just Nothing

    fmtHelp program helpFlags shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))
      <> if A.length helpFlags == 0
          then ""
          else "\n" <> "See "
                        <> program <> " " <> (intercalate "/" helpFlags)
                        <> " for more information"

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)


Moved stuff in gonimo webrtc to purescript-webrtc

module Gonimo.WebRTC where

import Prelude
import Data.Generic (class Generic)
import Data.Maybe (Maybe)
import Data.Nullable (toMaybe, toNullable, Nullable)

-- data Signal =
--     ICECandidate String
--   | Description String

-- data Error =
--   ParseError String -- A signaling message could not be parsed

-- type Config = {
--     settings :: Settings
--   , ourId :: DeviceId
--   , sendSignaling :: SendSignaling
--   , sendErrors :: ErrorReceiver
--   , iceServers :: Array { url :: String }
--   }

-- testICEServer = "stun:stun.l.google.com:19302"

-- type SendSignaling = String -> IO Unit
-- type ErrorReceiver = Error -> IO Unit

-- type Connection =
--   { config :: Config
--   , rtcConnection :: RTCPeerConnection
--   }

-- make :: Config -> IO Connection
-- make c = do
--   conn <- newRTCPeerConnection { iceServers : c.iceServers }
--   pure
--     { config : c
--     , rtcConnection : conn
--     }

-- addStream :: MediaStream -> Connection -> IO Unit
-- addStream stream conn = addStream conn.rtcConnection stream

-- receiveSignaling :: String -> Connection -> IO Unit
-- receiveSignal = unsafeCrashWith "Not yet implemented"

-- parseSignal :: String -> Either Error Signal

module Gonimo.WebRTC where

import Prelude
import Data.Generic (class Generic)
import Data.Maybe (Maybe)
import Data.Nullable (toMaybe, toNullable, Nullable)
import WebRTC.RTC (RTCIceCandidate)

newtype IceCandidate = IceCandidate { sdpMLineIndex :: Maybe Int
                                    , sdpMid :: Maybe String
                                    , candidate :: String
                                    }

derive instance genericIceCandidate :: Generic IceCandidate

toJS :: IceCandidate -> RTCIceCandidate
toJS (IceCandidate icecandidate)= {
    candidate : icecandidate.candidate
  , sdpMid  : toNullable icecandidate.sdpMid
  , sdpMLineIndex : toNullable icecandidate.sdpMLineIndex
  }

fromJS :: RTCIceCandidate -> IceCandidate
fromJS icecandidate = IceCandidate
  { candidate : icecandidate.candidate
  , sdpMid  : toMaybe icecandidate.sdpMid
  , sdpMLineIndex : toMaybe icecandidate.sdpMLineIndex
  }

type SessionDescription = { sdp :: String, "type" :: String }

-- data Signal =
--     ICECandidate String
--   | Description String

-- data Error =
--   ParseError String -- A signaling message could not be parsed

-- type Config = {
--     settings :: Settings
--   , ourId :: DeviceId
--   , sendSignaling :: SendSignaling
--   , sendErrors :: ErrorReceiver
--   , iceServers :: Array { url :: String }
--   }

-- testICEServer = "stun:stun.l.google.com:19302"

-- type SendSignaling = String -> IO Unit
-- type ErrorReceiver = Error -> IO Unit

-- type Connection =
--   { config :: Config
--   , rtcConnection :: RTCPeerConnection
--   }

-- make :: Config -> IO Connection
-- make c = do
--   conn <- newRTCPeerConnection { iceServers : c.iceServers }
--   pure
--     { config : c
--     , rtcConnection : conn
--     }

-- addStream :: MediaStream -> Connection -> IO Unit
-- addStream stream conn = addStream conn.rtcConnection stream

-- receiveSignaling :: String -> Connection -> IO Unit
-- receiveSignal = unsafeCrashWith "Not yet implemented"

-- parseSignal :: String -> Either Error Signal


Fix tests for purs 0.13 (#119)

Fix tests for purs 0.13 (#119)

module Test.Data.String.CodePoints (testStringCodePoints) where

import Prelude

import Data.Enum (fromEnum, toEnum)
import Data.Maybe (Maybe(..), fromJust)
import Data.String.CodePoints as SCP
import Data.String.Pattern (Pattern(..))
import Effect (Effect)
import Effect.Console (log)
import Partial.Unsafe (unsafePartial)
import Test.Assert (assertEqual)

str :: String
str = "a\xDC00\xD800\xD800\x16805\x16A06z"

testStringCodePoints :: Effect Unit
testStringCodePoints = do

  log "show"
  assertEqual
    { actual: map show (SCP.codePointAt 0 str)
    , expected: Just "(CodePoint 0x61)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 1 str)
    , expected: Just "(CodePoint 0xDC00)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 2 str)
    , expected: Just "(CodePoint 0xD800)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 3 str)
    , expected: Just "(CodePoint 0xD800)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 4 str)
    , expected: Just "(CodePoint 0x16805)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 5 str)
    , expected: Just "(CodePoint 0x16A06)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 6 str)
    , expected: Just "(CodePoint 0x7A)"
    }

  log "codePointFromChar"
  assertEqual
    { actual: Just (SCP.codePointFromChar 'A')
    , expected: (toEnum 65)
    }
  assertEqual
    { actual: (SCP.codePointFromChar <$> toEnum 0)
    , expected: toEnum 0
    }
  assertEqual
    { actual: (SCP.codePointFromChar <$> toEnum 0xFFFF)
    , expected: toEnum 0xFFFF
    }

  log "singleton"
  assertEqual
    { actual: (SCP.singleton <$> toEnum 0x30)
    , expected: Just "0"
    }
  assertEqual
    { actual: (SCP.singleton <$> toEnum 0x16805)
    , expected: Just "\x16805"
    }

  log "codePointAt"
  assertEqual
    { actual: SCP.codePointAt (-1) str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.codePointAt 0 str
    , expected: (toEnum 0x61)
    }
  assertEqual
    { actual: SCP.codePointAt 1 str
    , expected: (toEnum 0xDC00)
    }
  assertEqual
    { actual: SCP.codePointAt 2 str
    , expected: (toEnum 0xD800)
    }
  assertEqual
    { actual: SCP.codePointAt 3 str
    , expected: (toEnum 0xD800)
    }
  assertEqual
    { actual: SCP.codePointAt 4 str
    , expected: (toEnum 0x16805)
    }
  assertEqual
    { actual: SCP.codePointAt 5 str
    , expected: (toEnum 0x16A06)
    }
  assertEqual
    { actual: SCP.codePointAt 6 str
    , expected: (toEnum 0x7A)
    }
  assertEqual
    { actual: SCP.codePointAt 7 str
    , expected: Nothing
    }

  log "uncons"
  assertEqual
    { actual: SCP.uncons str
    , expected: Just {head: cp 0x61, tail:  "\xDC00\xD800\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 1 str)
    , expected: Just {head: cp 0xDC00, tail: "\xD800\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 2 str)
    , expected: Just {head: cp 0xD800, tail: "\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 3 str)
    , expected: Just {head: cp 0xD800, tail: "\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 4 str)
    , expected: Just {head: cp 0x16805, tail: "\x16A06z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 5 str)
    , expected: Just {head: cp 0x16A06, tail: "z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 6 str)
    , expected: Just {head: cp 0x7A, tail: ""}
    }
  assertEqual
    { actual: SCP.uncons ""
    , expected: Nothing
    }

  log "length"
  assertEqual
    { actual: SCP.length ""
    , expected: 0
    }
  assertEqual
    { actual: SCP.length "a"
    , expected: 1
    }
  assertEqual
    { actual: SCP.length "ab"
    , expected: 2
    }
  assertEqual
    { actual: SCP.length str
    , expected: 7
    }

  log "countPrefix"
  assertEqual
    { actual: SCP.countPrefix (\_ -> true) ""
    , expected: 0
    }
  assertEqual
    { actual: SCP.countPrefix (\_ -> false) str
    , expected: 0
    }
  assertEqual
    { actual: SCP.countPrefix (\_ -> true) str
    , expected: 7
    }
  assertEqual
    { actual: SCP.countPrefix (\x -> fromEnum x < 0xFFFF) str
    , expected: 4
    }
  assertEqual
    { actual: SCP.countPrefix (\x -> fromEnum x < 0xDC00) str
    , expected: 1
    }

  log "indexOf"
  assertEqual
    { actual: SCP.indexOf (Pattern "") ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern str) str
      , expected: Just 0
      }
  assertEqual
    { actual: SCP.indexOf (Pattern "a") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xDC00\xD800\xD800") str
    , expected: Just 1
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\xD81A") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\x16805") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\x16805") str
    , expected: Just 4
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\x16A06") str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "z") str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\n") str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD81A") str
    , expected: Just 4
    }

  log "indexOf'"
  assertEqual
    { actual: SCP.indexOf' (Pattern "") 0 ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern str) 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern str) 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "a") 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "a") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 0 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 1 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 2 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 3 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 4 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 5 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 6 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 7 str
    , expected: Nothing
    }

  log "lastIndexOf"
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "") ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "") str
    , expected: Just 7
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern str) str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "a") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xDC00\xD800\xD800") str
    , expected: Just 1
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\xD81A") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\x16805") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\x16805") str
    , expected: Just 4
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\x16A06") str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "z") str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\n") str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD81A") str
    , expected: Just 5
    }

  log "lastIndexOf'"
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "") 0 ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern str) 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern str) 1 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "a") 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "a") 7 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 0 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 2 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 3 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 4 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 5 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 6 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 7 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 7 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 6 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 5 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 4 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 3 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 2 str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 0 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 7 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 6 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 5 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 4 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 3 str
    , expected: Nothing
    }

  log "take"
  assertEqual
    { actual: SCP.take (-1) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.take 0 str
    , expected: ""
    }
  assertEqual
    { actual: SCP.take 1 str
    , expected: "a"
    }
  assertEqual
    { actual: SCP.take 2 str
    , expected: "a\xDC00"
    }
  assertEqual
    { actual: SCP.take 3 str
    , expected: "a\xDC00\xD800"
    }
  assertEqual
    { actual: SCP.take 4 str
    , expected: "a\xDC00\xD800\xD800"
    }
  assertEqual
    { actual: SCP.take 5 str
    , expected: "a\xDC00\xD800\xD800\x16805"
    }
  assertEqual
    { actual: SCP.take 6 str
    , expected: "a\xDC00\xD800\xD800\x16805\x16A06"
    }
  assertEqual
    { actual: SCP.take 7 str
    , expected: str
    }
  assertEqual
    { actual: SCP.take 8 str
    , expected: str
    }

  log "takeWhile"
  assertEqual
    { actual: SCP.takeWhile (\_ -> true) str
    , expected: str
    }
  assertEqual
    { actual: SCP.takeWhile (\_ -> false) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.takeWhile (\c -> fromEnum c < 0xFFFF) str
    , expected: "a\xDC00\xD800\xD800"
    }
  assertEqual
    { actual: SCP.takeWhile (\c -> fromEnum c < 0xDC00) str
    , expected: "a"
    }

  log "drop"
  assertEqual
    { actual: SCP.drop (-1) str
    , expected: str
    }
  assertEqual
    { actual: SCP.drop 0 str
    , expected: str
    }
  assertEqual
    { actual: SCP.drop 1 str
    , expected: "\xDC00\xD800\xD800\x16805\x16A06z"
    }
  assertEqual
    { actual: SCP.drop 2 str
    , expected: "\xD800\xD800\x16805\x16A06z"
    }
  assertEqual
    { actual: SCP.drop 3 str
    , expected: "\xD800\x16805\x16A06z"
    }
  assertEqual
    { actual: SCP.drop 4 str
    , expected: "\x16805\x16A06z"
    }
  assertEqual
    { actual: SCP.drop 5 str
    , expected: "\x16A06z"
    }
  assertEqual
    { actual: SCP.drop 6 str
    , expected: "z"
    }
  assertEqual
    { actual: SCP.drop 7 str
    , expected: ""
    }
  assertEqual
    { actual: SCP.drop 8 str
    , expected: ""
    }

  log "dropWhile"
  assertEqual
    { actual: SCP.dropWhile (\_ -> true) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.dropWhile (\_ -> false) str
    , expected: str
    }
  assertEqual
    { actual: SCP.dropWhile (\c -> fromEnum c < 0xFFFF) str
    , expected: "\x16805\x16A06z"
    }
  assertEqual
    { actual: SCP.dropWhile (\c -> fromEnum c < 0xDC00) str
    , expected: "\xDC00\xD800\xD800\x16805\x16A06z"
    }

  log "splitAt"
  assertEqual
    { actual: SCP.splitAt 0 ""
    , expected: {before: "", after: "" }
    }
  assertEqual
    { actual: SCP.splitAt 1 ""
    , expected: {before: "", after: "" }
    }
  assertEqual
    { actual: SCP.splitAt 0 "a"
    , expected: {before: "", after: "a"}
    }
  assertEqual
    { actual: SCP.splitAt 1 "ab"
    , expected: {before: "a", after: "b"}
    }
  assertEqual
    { actual: SCP.splitAt 3 "aabcc"
    , expected: {before: "aab", after: "cc"}
    }
  assertEqual
    { actual: SCP.splitAt (-1) "abc"
    , expected: {before: "", after: "abc"}
    }
  assertEqual
    { actual: SCP.splitAt 0 str
    , expected: {before: "", after: str}
    }
  assertEqual
    { actual: SCP.splitAt 1 str
    , expected: {before: "a", after: "\xDC00\xD800\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.splitAt 2 str
    , expected: {before: "a\xDC00", after: "\xD800\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.splitAt 3 str
    , expected: {before: "a\xDC00\xD800", after: "\xD800\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.splitAt 4 str
    , expected: {before: "a\xDC00\xD800\xD800", after: "\x16805\x16A06z"}
    }
  assertEqual
    { actual: SCP.splitAt 5 str
    , expected: {before: "a\xDC00\xD800\xD800\x16805", after: "\x16A06z"}
    }
  assertEqual
    { actual: SCP.splitAt 6 str
    , expected: {before: "a\xDC00\xD800\xD800\x16805\x16A06", after: "z"}
    }
  assertEqual
    { actual: SCP.splitAt 7 str
    , expected: {before: str, after: ""}
    }
  assertEqual
    { actual: SCP.splitAt 8 str
    , expected: {before: str, after: ""}
    }

cp :: Int -> SCP.CodePoint
cp = unsafePartial fromJust <<< toEnum

module Test.Data.String.CodePoints (testStringCodePoints) where

import Prelude

import Data.Enum (fromEnum, toEnum)
import Data.Maybe (Maybe(..), fromJust)
import Data.String.CodePoints as SCP
import Data.String.Pattern (Pattern(..))
import Effect (Effect)
import Effect.Console (log)
import Partial.Unsafe (unsafePartial)
import Test.Assert (assertEqual)

str :: String
str = "a\xDC00\xD800\xD800\x16805\x16A06\&z"

testStringCodePoints :: Effect Unit
testStringCodePoints = do

  log "show"
  assertEqual
    { actual: map show (SCP.codePointAt 0 str)
    , expected: Just "(CodePoint 0x61)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 1 str)
    , expected: Just "(CodePoint 0xDC00)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 2 str)
    , expected: Just "(CodePoint 0xD800)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 3 str)
    , expected: Just "(CodePoint 0xD800)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 4 str)
    , expected: Just "(CodePoint 0x16805)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 5 str)
    , expected: Just "(CodePoint 0x16A06)"
    }
  assertEqual
    { actual: map show (SCP.codePointAt 6 str)
    , expected: Just "(CodePoint 0x7A)"
    }

  log "codePointFromChar"
  assertEqual
    { actual: Just (SCP.codePointFromChar 'A')
    , expected: (toEnum 65)
    }
  assertEqual
    { actual: (SCP.codePointFromChar <$> toEnum 0)
    , expected: toEnum 0
    }
  assertEqual
    { actual: (SCP.codePointFromChar <$> toEnum 0xFFFF)
    , expected: toEnum 0xFFFF
    }

  log "singleton"
  assertEqual
    { actual: (SCP.singleton <$> toEnum 0x30)
    , expected: Just "0"
    }
  assertEqual
    { actual: (SCP.singleton <$> toEnum 0x16805)
    , expected: Just "\x16805"
    }

  log "codePointAt"
  assertEqual
    { actual: SCP.codePointAt (-1) str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.codePointAt 0 str
    , expected: (toEnum 0x61)
    }
  assertEqual
    { actual: SCP.codePointAt 1 str
    , expected: (toEnum 0xDC00)
    }
  assertEqual
    { actual: SCP.codePointAt 2 str
    , expected: (toEnum 0xD800)
    }
  assertEqual
    { actual: SCP.codePointAt 3 str
    , expected: (toEnum 0xD800)
    }
  assertEqual
    { actual: SCP.codePointAt 4 str
    , expected: (toEnum 0x16805)
    }
  assertEqual
    { actual: SCP.codePointAt 5 str
    , expected: (toEnum 0x16A06)
    }
  assertEqual
    { actual: SCP.codePointAt 6 str
    , expected: (toEnum 0x7A)
    }
  assertEqual
    { actual: SCP.codePointAt 7 str
    , expected: Nothing
    }

  log "uncons"
  assertEqual
    { actual: SCP.uncons str
    , expected: Just {head: cp 0x61, tail:  "\xDC00\xD800\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 1 str)
    , expected: Just {head: cp 0xDC00, tail: "\xD800\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 2 str)
    , expected: Just {head: cp 0xD800, tail: "\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 3 str)
    , expected: Just {head: cp 0xD800, tail: "\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 4 str)
    , expected: Just {head: cp 0x16805, tail: "\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 5 str)
    , expected: Just {head: cp 0x16A06, tail: "z"}
    }
  assertEqual
    { actual: SCP.uncons (SCP.drop 6 str)
    , expected: Just {head: cp 0x7A, tail: ""}
    }
  assertEqual
    { actual: SCP.uncons ""
    , expected: Nothing
    }

  log "length"
  assertEqual
    { actual: SCP.length ""
    , expected: 0
    }
  assertEqual
    { actual: SCP.length "a"
    , expected: 1
    }
  assertEqual
    { actual: SCP.length "ab"
    , expected: 2
    }
  assertEqual
    { actual: SCP.length str
    , expected: 7
    }

  log "countPrefix"
  assertEqual
    { actual: SCP.countPrefix (\_ -> true) ""
    , expected: 0
    }
  assertEqual
    { actual: SCP.countPrefix (\_ -> false) str
    , expected: 0
    }
  assertEqual
    { actual: SCP.countPrefix (\_ -> true) str
    , expected: 7
    }
  assertEqual
    { actual: SCP.countPrefix (\x -> fromEnum x < 0xFFFF) str
    , expected: 4
    }
  assertEqual
    { actual: SCP.countPrefix (\x -> fromEnum x < 0xDC00) str
    , expected: 1
    }

  log "indexOf"
  assertEqual
    { actual: SCP.indexOf (Pattern "") ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern str) str
      , expected: Just 0
      }
  assertEqual
    { actual: SCP.indexOf (Pattern "a") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xDC00\xD800\xD800") str
    , expected: Just 1
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\xD81A") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD800\x16805") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\x16805") str
    , expected: Just 4
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\x16A06") str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "z") str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\0") str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf (Pattern "\xD81A") str
    , expected: Just 4
    }

  log "indexOf'"
  assertEqual
    { actual: SCP.indexOf' (Pattern "") 0 ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern str) 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern str) 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "a") 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "a") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 0 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 1 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 2 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 3 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 4 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 5 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 6 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.indexOf' (Pattern "z") 7 str
    , expected: Nothing
    }

  log "lastIndexOf"
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "") ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "") str
    , expected: Just 7
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern str) str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "a") str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xDC00\xD800\xD800") str
    , expected: Just 1
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\xD800") str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\xD81A") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD800\x16805") str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\x16805") str
    , expected: Just 4
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\x16A06") str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "z") str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\0") str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf (Pattern "\xD81A") str
    , expected: Just 5
    }

  log "lastIndexOf'"
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "") 0 ""
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern str) 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern str) 1 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "a") 0 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "a") 7 str
    , expected: Just 0
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 0 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 2 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 3 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 4 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 5 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 6 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "z") 7 str
    , expected: Just 6
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 7 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 6 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 5 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 4 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 3 str
    , expected: Just 3
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 2 str
    , expected: Just 2
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 1 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\xD800") 0 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 7 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 6 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 5 str
    , expected: Just 5
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 4 str
    , expected: Nothing
    }
  assertEqual
    { actual: SCP.lastIndexOf' (Pattern "\x16A06") 3 str
    , expected: Nothing
    }

  log "take"
  assertEqual
    { actual: SCP.take (-1) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.take 0 str
    , expected: ""
    }
  assertEqual
    { actual: SCP.take 1 str
    , expected: "a"
    }
  assertEqual
    { actual: SCP.take 2 str
    , expected: "a\xDC00"
    }
  assertEqual
    { actual: SCP.take 3 str
    , expected: "a\xDC00\xD800"
    }
  assertEqual
    { actual: SCP.take 4 str
    , expected: "a\xDC00\xD800\xD800"
    }
  assertEqual
    { actual: SCP.take 5 str
    , expected: "a\xDC00\xD800\xD800\x16805"
    }
  assertEqual
    { actual: SCP.take 6 str
    , expected: "a\xDC00\xD800\xD800\x16805\x16A06"
    }
  assertEqual
    { actual: SCP.take 7 str
    , expected: str
    }
  assertEqual
    { actual: SCP.take 8 str
    , expected: str
    }

  log "takeWhile"
  assertEqual
    { actual: SCP.takeWhile (\_ -> true) str
    , expected: str
    }
  assertEqual
    { actual: SCP.takeWhile (\_ -> false) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.takeWhile (\c -> fromEnum c < 0xFFFF) str
    , expected: "a\xDC00\xD800\xD800"
    }
  assertEqual
    { actual: SCP.takeWhile (\c -> fromEnum c < 0xDC00) str
    , expected: "a"
    }

  log "drop"
  assertEqual
    { actual: SCP.drop (-1) str
    , expected: str
    }
  assertEqual
    { actual: SCP.drop 0 str
    , expected: str
    }
  assertEqual
    { actual: SCP.drop 1 str
    , expected: "\xDC00\xD800\xD800\x16805\x16A06\&z"
    }
  assertEqual
    { actual: SCP.drop 2 str
    , expected: "\xD800\xD800\x16805\x16A06\&z"
    }
  assertEqual
    { actual: SCP.drop 3 str
    , expected: "\xD800\x16805\x16A06\&z"
    }
  assertEqual
    { actual: SCP.drop 4 str
    , expected: "\x16805\x16A06\&z"
    }
  assertEqual
    { actual: SCP.drop 5 str
    , expected: "\x16A06\&z"
    }
  assertEqual
    { actual: SCP.drop 6 str
    , expected: "z"
    }
  assertEqual
    { actual: SCP.drop 7 str
    , expected: ""
    }
  assertEqual
    { actual: SCP.drop 8 str
    , expected: ""
    }

  log "dropWhile"
  assertEqual
    { actual: SCP.dropWhile (\_ -> true) str
    , expected: ""
    }
  assertEqual
    { actual: SCP.dropWhile (\_ -> false) str
    , expected: str
    }
  assertEqual
    { actual: SCP.dropWhile (\c -> fromEnum c < 0xFFFF) str
    , expected: "\x16805\x16A06\&z"
    }
  assertEqual
    { actual: SCP.dropWhile (\c -> fromEnum c < 0xDC00) str
    , expected: "\xDC00\xD800\xD800\x16805\x16A06\&z"
    }

  log "splitAt"
  assertEqual
    { actual: SCP.splitAt 0 ""
    , expected: {before: "", after: "" }
    }
  assertEqual
    { actual: SCP.splitAt 1 ""
    , expected: {before: "", after: "" }
    }
  assertEqual
    { actual: SCP.splitAt 0 "a"
    , expected: {before: "", after: "a"}
    }
  assertEqual
    { actual: SCP.splitAt 1 "ab"
    , expected: {before: "a", after: "b"}
    }
  assertEqual
    { actual: SCP.splitAt 3 "aabcc"
    , expected: {before: "aab", after: "cc"}
    }
  assertEqual
    { actual: SCP.splitAt (-1) "abc"
    , expected: {before: "", after: "abc"}
    }
  assertEqual
    { actual: SCP.splitAt 0 str
    , expected: {before: "", after: str}
    }
  assertEqual
    { actual: SCP.splitAt 1 str
    , expected: {before: "a", after: "\xDC00\xD800\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.splitAt 2 str
    , expected: {before: "a\xDC00", after: "\xD800\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.splitAt 3 str
    , expected: {before: "a\xDC00\xD800", after: "\xD800\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.splitAt 4 str
    , expected: {before: "a\xDC00\xD800\xD800", after: "\x16805\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.splitAt 5 str
    , expected: {before: "a\xDC00\xD800\xD800\x16805", after: "\x16A06\&z"}
    }
  assertEqual
    { actual: SCP.splitAt 6 str
    , expected: {before: "a\xDC00\xD800\xD800\x16805\x16A06", after: "z"}
    }
  assertEqual
    { actual: SCP.splitAt 7 str
    , expected: {before: str, after: ""}
    }
  assertEqual
    { actual: SCP.splitAt 8 str
    , expected: {before: str, after: ""}
    }

cp :: Int -> SCP.CodePoint
cp = unsafePartial fromJust <<< toEnum


Use `<$>`

Use `<$>`

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  x <- _ARGNAME <|> _argname_
  return $ Positional x

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  xs <- Array.some $ matches "[a-z]"
  arg <- (do
    many $ char ' '
    arg <- (_ARGNAME <|> _argname_)
    return $ Just arg) <|> (return Nothing)
  return $ LongOpt (fromCharArray xs) arg

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  char '-'
  ShortOpt
    <$> (matches "[a-z]")
    <*> (Array.many $ matches "[a-z]")
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* space
  Position { column: col } <- getPosition

  -- First line of usage tokens
  x <- usageToken `sepBy` (many space)

  xs <- (many $ try do
    many space *> eol
    indent (col - 1)
    many space
    usageToken `sepBy` many space)

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  x <- _ARGNAME <|> _argname_
  return $ Positional x

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  xs <- Array.some $ matches "[a-z]"
  arg <- (do
    many $ char ' '
    arg <- (_ARGNAME <|> _argname_)
    return $ Just arg) <|> (return Nothing)
  return $ LongOpt (fromCharArray xs) arg

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  string "-"
  x <- matches "[a-z]"
  stacked <- Array.many $ matches "[a-z]"
  arg <- (do
    many $ char ' '
    arg <- (_ARGNAME <|> _argname_)
    return $ Just arg) <|> (return Nothing)
  return $ ShortOpt x stacked arg

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do
  -- | Program name
  string program <* space
  Position { column: col } <- getPosition

  -- | First line of usage tokens
  x <- usageToken `sepBy` (many space)

  xs <- (many $ try $ do
    many space *> eol
    indent (col - 1)
    debugPosition
    many space
    usageToken `sepBy` (many space))

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit


Fix typo: arguement → argument

Fix typo: arguement → argument

module Control.Parallel
  ( parApply
  , parTraverse
  , parTraverse_
  , parSequence
  , parSequence_
  , parOneOf
  , parOneOfMap
  , module Control.Parallel.Class
  ) where

import Prelude

import Control.Alternative (class Alternative)
import Control.Parallel.Class (class Parallel, parallel, sequential, ParCont(..))

import Data.Foldable (class Foldable, traverse_, oneOfMap)
import Data.Traversable (class Traversable, traverse)

-- | Apply a function to an argument under a type constructor in parallel.
parApply
  :: forall f m a b
   . Parallel f m
   => m (a -> b)
   -> m a
   -> m b
parApply mf ma = sequential(apply (parallel mf) (parallel ma))

-- | Traverse a collection in parallel.
parTraverse
  :: forall f m t a b
   . Parallel f m
  => Traversable t
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = sequential <<< traverse (parallel <<< f)

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall f m t a b
   . Parallel f m
  => Foldable t
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = sequential <<< traverse_ (parallel <<< f)

parSequence
  :: forall a t m f
   . Parallel f m
  => Traversable t
  => t (m a)
  -> m (t a)
parSequence = parTraverse identity

parSequence_
  :: forall a t m f
   . Parallel f m
  => Foldable t
  => t (m a)
  -> m Unit
parSequence_ = parTraverse_ identity

-- | Race a collection in parallel.
parOneOf
  :: forall a t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => t (m a)
  -> m a
parOneOf = sequential <<< oneOfMap parallel

-- | Race a collection in parallel while mapping to some effect.
parOneOfMap
  :: forall a b t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => (a -> m b)
  -> t a
  -> m b
parOneOfMap f = sequential <<< oneOfMap (parallel <<< f)

module Control.Parallel
  ( parApply
  , parTraverse
  , parTraverse_
  , parSequence
  , parSequence_
  , parOneOf
  , parOneOfMap
  , module Control.Parallel.Class
  ) where

import Prelude

import Control.Alternative (class Alternative)
import Control.Parallel.Class (class Parallel, parallel, sequential, ParCont(..))

import Data.Foldable (class Foldable, traverse_, oneOfMap)
import Data.Traversable (class Traversable, traverse)

-- | Apply a function to an arguement under a type constructor in parallel.
parApply
  :: forall f m a b
   . Parallel f m
   => m (a -> b)
   -> m a
   -> m b
parApply mf ma = sequential(apply (parallel mf) (parallel ma))

-- | Traverse a collection in parallel.
parTraverse
  :: forall f m t a b
   . Parallel f m
  => Traversable t
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = sequential <<< traverse (parallel <<< f)

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall f m t a b
   . Parallel f m
  => Foldable t
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = sequential <<< traverse_ (parallel <<< f)

parSequence
  :: forall a t m f
   . Parallel f m
  => Traversable t
  => t (m a)
  -> m (t a)
parSequence = parTraverse identity

parSequence_
  :: forall a t m f
   . Parallel f m
  => Foldable t
  => t (m a)
  -> m Unit
parSequence_ = parTraverse_ identity

-- | Race a collection in parallel.
parOneOf
  :: forall a t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => t (m a)
  -> m a
parOneOf = sequential <<< oneOfMap parallel

-- | Race a collection in parallel while mapping to some effect.
parOneOfMap
  :: forall a b t m f
   . Parallel f m
  => Alternative f
  => Foldable t
  => Functor t
  => (a -> m b)
  -> t a
  -> m b
parOneOfMap f = sequential <<< oneOfMap (parallel <<< f)