feat: Could not match type NonEmptyList with type Array

module Database.PostgreSQL.Value where

-- | `node-postgres` is playing guessing game regarding type conversions
-- | so we are overriding its defualt behavior for some types - please
-- | check PostgreSQL.js

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Argonaut (Json)
import Data.Argonaut (stringify) as Argonaut
import Data.Foldable (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Generic.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

else instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

else instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

else instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

else instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

else instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

else instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

else instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

else instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

else instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

else instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

else instance fromSQLValueObject :: FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo

else instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

else instance fromSQLValueJson :: FromSQLValue Json where
  fromSQLValue = Right <<< unsafeFromForeign

newtypeFromSQLValue ∷ ∀ a b. Newtype a b ⇒ FromSQLValue b ⇒ Foreign → Either String a
newtypeFromSQLValue = map wrap <<< fromSQLValue

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

else instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

else instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

else instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

else instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

else instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

else instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

else instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

else instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

else instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

else instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

else instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

else instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

else instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

else instance toSQLValueDecimal :: ToSQLValue Decimal where
  toSQLValue = Decimal.toString >>> unsafeToForeign

else instance toSQLValueJson :: ToSQLValue Json where
  -- | We are forced to stringify value here to avoid
  -- | problems with pg auto conversions - please check for example:
  -- | https://github.com/brianc/node-postgres/issues/1383
  toSQLValue = Argonaut.stringify >>> unsafeToForeign

newtypeToSQLValue ∷ ∀ a b. Newtype a b ⇒ ToSQLValue b ⇒ a → Foreign
newtypeToSQLValue = unwrap >>> toSQLValue

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

module Database.PostgreSQL.Value where

-- | `node-postgres` is playing guessing game regarding type conversions
-- | so we are overriding its defualt behavior for some types - please
-- | check PostgreSQL.js

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Argonaut (Json)
import Data.Argonaut (stringify) as Argonaut
import Data.Array (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Generic.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

else instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

else instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

else instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

else instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

else instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

else instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

else instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

else instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

else instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

else instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

else instance fromSQLValueObject :: FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo

else instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

else instance fromSQLValueJson :: FromSQLValue Json where
  fromSQLValue = Right <<< unsafeFromForeign

newtypeFromSQLValue ∷ ∀ a b. Newtype a b ⇒ FromSQLValue b ⇒ Foreign → Either String a
newtypeFromSQLValue = map wrap <<< fromSQLValue

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

else instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

else instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

else instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

else instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

else instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

else instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

else instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

else instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

else instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

else instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

else instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

else instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

else instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

else instance toSQLValueDecimal :: ToSQLValue Decimal where
  toSQLValue = Decimal.toString >>> unsafeToForeign

else instance toSQLValueJson :: ToSQLValue Json where
  -- | We are forced to stringify value here to avoid
  -- | problems with pg auto conversions - please check for example:
  -- | https://github.com/brianc/node-postgres/issues/1383
  toSQLValue = Argonaut.stringify >>> unsafeToForeign

newtypeToSQLValue ∷ ∀ a b. Newtype a b ⇒ ToSQLValue b ⇒ a → Foreign
newtypeToSQLValue = unwrap >>> toSQLValue

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean


Use `case _ of` with `<#>`

Use `case _ of` with `<#>`

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Array as A
import Data.String as S
import Data.String.Unsafe as US
import Control.Alt ((<|>))
import Control.MonadPlus (guard)
import Control.MonadPlus.Partial (mpartition)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either, fromRight)
import Data.Foldable (any, elem)
import Data.Function (on)
import Data.Functor ((<$))
import Data.List (findIndex, groupBy, List(..), length, filter, singleton,
                  fromFoldable, catMaybes, head, (:), concat, reverse)
import Data.Maybe (fromMaybe, Maybe(Nothing, Just), isNothing, maybe, isJust,
                  fromJust)
import Data.String (fromCharArray, toCharArray, toUpper)
import Data.String (singleton) as String
import Data.String.Ext ((^=), endsWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String as Str
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.NonEmpty as NonEmpty

import Language.Docopt.Argument
import Language.Docopt.Argument (isFree) as Arg
import Language.Docopt.OptionAlias (Aliases(), OptionAlias(..))
import Language.Docopt.OptionAlias (OptionAlias(..)) as OptionAlias
import Language.Docopt.SpecParser.Desc as Desc
import Language.Docopt.Argument (Argument(..), Branch, OptionArgument(..))
import Language.Docopt.Errors (SolveError(..))
import Language.Docopt.SpecParser (Desc(), Usage()) as SpecParser
import Language.Docopt.SpecParser.Usage.Argument (Branch, Argument(..)) as U
import Language.Docopt.Usage (Usage)
import Partial.Unsafe (unsafePartial)

foreign import undefined :: forall a. a

type Reference = String -- [options] reference

data Slurp a
  = Slurp (List a) -- slurp the adjacent argument
  | Keep  (List a) -- keep  the adjacent argument

data ResolveTo a b
  = Resolved   a
  | Unresolved b

posArgsEq :: String -> String -> Boolean
posArgsEq = eq `on` (Str.toUpper <<< stripAngles)
infixl 9 posArgsEq as ^=^

stripAngles :: String -> String
stripAngles = stripPrefix <<< stripSuffix
  where
  stripPrefix s = fromMaybe s (Str.stripPrefix "<" s)
  stripSuffix s = fromMaybe s (Str.stripSuffix ">" s)

instance showResolveTo :: (Show a, Show b) => Show (ResolveTo a b) where
  show (Resolved   a) = "Resolved "   <> show a
  show (Unresolved b) = "Unresolved " <> show b

fail :: forall a. String -> Either SolveError a
fail = Left <<< SolveError

solveBranch
  :: U.Branch                 -- ^ the usage branch
  -> List SpecParser.Desc     -- ^ the option descriptions
  -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go args = do
      solved <- solveArgs args
      pure do
        clump <- groupFree solved
        case partition clump of
          Tuple surroundingArgs _ -> do
            x <- clump
            case x of
              Resolved x   -> pure x
              Unresolved _ -> expand ds surroundingArgs

      where
        groupFree
          :: List (ResolveTo Argument Reference)
          -> List (List (ResolveTo Argument Reference))
        groupFree = groupBy (eq `on` isFree)

        partition
          :: forall a b
           . List (ResolveTo a b)
          -> Tuple (List a) (List b)
        partition = f <<< mpartition isResolved
          where f = bimap (\x -> concat $ x <#> case _ of
                            (Resolved x) -> pure x
                            otherwise    -> Nil
                          )
                          (\x -> concat $ x <#> case _ of
                            (Unresolved x) -> pure x
                            otherwise      -> Nil
                          )

        expand
          :: List SpecParser.Desc
          -> List Argument
          -> List Argument
        expand ds surroundingArgs = reverse $ go ds surroundingArgs Nil
          where
          go :: List SpecParser.Desc -> List Argument -> List Argument -> List Argument
          go ((x@(Desc.OptionDesc desc)):xs) surroundingArgs acc = do
            -- Assuming description and usage have already been merged,
            -- find all options that are not present in the surrounding
            -- "free" area and add them.
            if isJust (findIndex (isMatch desc.aliases) surroundingArgs)
                then go xs surroundingArgs acc
                else
                  let z = Group {
                          optional: true
                        , branches: (singleton $ singleton $ Option $
                              { aliases:    desc.aliases
                              , arg:        OptionArgument <$> desc.arg
                              , env:        desc.env
                              , repeatable: false
                              }
                          )
                        , repeatable: desc.repeatable
                        }
                  in go xs (z:surroundingArgs) (z:acc)
            where
              isMatch aliases (Option o)  = any (_ `elem` aliases) o.aliases
              isMatch aliases (Group grp) = any (isMatch aliases) (concat grp.branches)
              isMatch _ _                 = false

          go (_:xs) surroundingArgs acc = go xs surroundingArgs acc
          go _ _ acc = acc

        isFree :: forall b . ResolveTo Argument b -> Boolean
        isFree (Resolved a)   = Arg.isFree a
        isFree (Unresolved _) = true

        isResolved :: forall a b . ResolveTo a b -> Boolean
        isResolved (Resolved _) = true
        isResolved _            = false

    solveArgs :: U.Branch -> Either SolveError
                                    (List (ResolveTo Argument
                                                     Reference))
    solveArgs Nil = pure Nil
    solveArgs (x:Nil) = do
      m <- solveArg x Nothing
      pure case m of
           Resolved (Slurp xs) -> Resolved <$> xs
           Resolved (Keep xs)  -> Resolved <$> xs
           Unresolved a        -> singleton $ Unresolved a
    solveArgs (x:y:xs) = do
      m <- solveArg x (Just y)
      case m of
           Resolved (Keep  zs) -> ((Resolved <$> zs) <> _) <$> solveArgs (y:xs)
           Resolved (Slurp zs) -> ((Resolved <$> zs) <> _) <$> solveArgs xs
           Unresolved a        -> ((singleton $ Unresolved a) <> _)
                                    <$> solveArgs (y:xs)

    simpleResolve v = Right $ Resolved $ Keep $ singleton v

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArg
      :: U.Argument
      -> Maybe U.Argument
      -> Either SolveError (ResolveTo (Slurp Argument) Reference)

    solveArg (U.Reference r) _ = pure $ Unresolved r
    solveArg (U.EOA) _         = simpleResolve EOA
    solveArg (U.Stdin) _       = simpleResolve Stdin

    solveArg (U.Command cmd) _ = simpleResolve
      $ Command {
          name:       cmd.name
        , repeatable: cmd.repeatable
        }

    solveArg (U.Positional pos) _ = simpleResolve
      $ Positional {
        name:       pos.name
      , repeatable: pos.repeatable
      }

    solveArg (U.Group grp) _ =
      Resolved <<< Keep <<< singleton <$> do
        branches <- flip solveBranch ds `traverse` grp.branches
        pure $ Group grp { branches = branches }

    solveArg (U.Option o) mAdjArg = do

      -- Find a matching option description, if any.
      descMatch <- matchDesc

      -- Check to see if this option has an explicitly bound argument.
      -- In this case, a check to consume an adjacent arg must not take place.
      case o.arg of
        (Just exarg) -> do
          -- Note: There is no check to see if an explicit argument is
          --       the same as specified in the option descriptions for
          --       convenience to the user.
          pure  $ Resolved
                $ Keep
                $ singleton
                $ Option descMatch

        Nothing -> do
          -- Look ahead if any of the following arguments should be slurped.
          -- Return either `Nothing` to signify that nothing should be slurped
          -- or a value signifieng that it should be slurped, and the
          -- `isRepeated` flag should be inherited.
          let
            adjArgMatch = do
              guard (not o.repeatable)
              (arg@{ name }) <- unOptionArgument <$> descMatch.arg
              adjArg <- mAdjArg
              (r /\ n /\ optional) <- case adjArg of
                (U.Positional pos) -> pure (pos.repeatable /\ pos.name /\ false)
                (U.Command    cmd) -> pure (cmd.repeatable /\ cmd.name /\ false)
                (U.Group { branches: (x : Nil) : Nil, optional, repeatable }) ->
                  case x of
                    (U.Positional pos) ->
                      pure ((pos.repeatable || repeatable) /\ pos.name /\ optional)
                    (U.Command    cmd) ->
                      pure ((cmd.repeatable || repeatable) /\ cmd.name /\ optional)
                    otherwise -> Nothing
                otherwise -> Nothing
              pure do
                guardArgs n name
                pure (r /\ arg { optional = optional })

          case adjArgMatch of
            Nothing -> do
              if not (fromMaybe true
                      $ (_.optional <<< unOptionArgument <$> descMatch.arg))
                 then do
                    fail
                      $ "Option-Argument specified in options-section missing"
                        <> " --" <> o.name
                  else
                    pure  $ Resolved
                          $ Keep
                          $ singleton
                          $ Option descMatch
            Just matched -> do
              (r /\ arg) <- matched
              pure  $ Resolved
                    $ Slurp
                    $ singleton
                    $ Option $ descMatch  { arg = pure (OptionArgument arg)
                                          , repeatable = r
                                          }

      where
        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^=^ n' = pure true
        guardArgs n n' = fail
          $ "Arguments mismatch for option --" <> o.name <> ": "
              <> show n <> " and " <> show n'

        matchDesc :: Either SolveError OptionObj
        matchDesc =
          case filter isMatch ds of

            xs | length xs > 1 -> fail
              $ "Multiple option descriptions for option --" <> o.name

            -- construct the option from itself and the matching description
            (Desc.OptionDesc desc) : Nil -> do
              arg <- resolveOptArg o.arg desc.arg
              pure  { aliases:    desc.aliases
                    , arg:        OptionArgument <$> arg
                    , env:        desc.env
                    , repeatable: o.repeatable
                    }

            -- default fallback: construct the option from itself alone
            otherwise ->
              pure  { aliases:    NonEmpty (OptionAlias.Long o.name) Nil
                    , env:        Nothing
                    , arg:        OptionArgument <$> convertArg o.arg
                    , repeatable: o.repeatable
                    }
          where
            isMatch (Desc.OptionDesc { aliases }) = flip any aliases case _ of
              OptionAlias.Long n -> n == o.name
              _                  -> false
            isMatch _ = false

    solveArg (U.OptionStack o) mAdjArg
      = fromSubsumption <|> fromAdjacentArgOrDefault

      where
        -- | Subsumption method:
        -- | (Only applies for options w/o explicit arg)
        -- |
        -- | Concatenate the option stack into a string,
        -- | then do a substring check for each possible description.
        -- |
        -- | "armmsg"
        -- |    ~~~~
        -- |    ^^
        -- |    |`- the arg  matches - case INSENSITIVE
        -- |    `-- the flag matches - case SENSITIVE
        -- |
        -- | Should this check yield a match, slice the matched
        -- | string off the stack and return the remainder option
        -- | stack (if any).
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromSubsumption :: Either SolveError
                                  (ResolveTo (Slurp Argument)
                                              Reference)
        fromSubsumption = do

          -- XXX: Well, this error should not be thrown, but rather,
          --      we should just not come to this code-path if this is
          --      the case. It would be an awkward user-facing error.
          if isJust o.arg
            then fail $ "Option stacks with explicit argument binding "
                     <> "may not be subsumed."
            else pure unit

          let fs  = fromCharArray $ o.flag A.: o.stack

          maybe (fail "No description subsumed option") pure do
            -- XXX: Purescript is not lazy, so this is too expensive.
            --      We can just stop at the first `Just` value.
            head $ catMaybes $ ds <#> case _ of
              (Desc.OptionDesc d) -> do
                head $ catMaybes $ fromFoldable $ d.aliases <#> case _ of
                  (OptionAlias.Short f) -> subsume f fs d
                  _                     -> Nothing
              _ -> Nothing

          where
            subsume
              :: Char
              -> String
              -> _
              -> Maybe (ResolveTo (Slurp Argument)
                       Reference)
            subsume f fs d = do
              a <- d.arg

              -- the haystack needs to be modified, such that the
              -- the last (length a.name) characters are uppercased
              -- and hence compared case INSENSITIVELY.
              let bareArgname = stripAngles a.name
                  needle      = toUpper $ String.singleton f <> bareArgname
                  haystack    = toUpper fs

              (Tuple fs o) <- if endsWith needle haystack
                then
                  let ix = S.length haystack - S.length needle
                   in if unsafePartial (US.charAt ix fs) == f
                        then pure
                          $ Tuple (toCharArray
                                    (S.take (S.length fs
                                              - S.length bareArgname
                                              - 1
                                            ) fs
                                    )
                                  )
                                  { aliases:    d.aliases
                                  , arg:        pure a
                                  , env:        d.env
                                  , repeatable: o.repeatable
                                  }
                    else Nothing
                else Nothing

              cs <- either (const Nothing)
                           (pure <<< id)
                           (matchDesc false `traverse` fs)

              -- set the same repeatability flag for each stacked option as
              -- indicated by trailing option.
              let cs' = flip setRepeatable o.repeatable <$> do
                          Option <$> fromFoldable cs

              pure  $ Resolved
                    $ Keep
                    $ cs' <> (singleton $ Option $ o {
                      arg = OptionArgument <$> o.arg
                    })

        -- | Last flag method (w/ fallback):
        -- |
        -- | Find the last char in the option stack, look it up
        -- | in the descriptions and when it was found to have an
        -- | argument, that matches the adjacent argument (or it's
        -- | explicit binding), consume that argument and produce
        -- | a list of remaining short options.
        -- |
        -- | "armmsg=ARG"
        -- | OR:
        -- | "armmsg ARG"
        -- |       ~ ~~~
        -- |       ^  ^
        -- |       |  `-- only slurped if description found and
        -- |       |      has matching argument.
        -- |       `----- look for a description of `-g``
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromAdjacentArgOrDefault :: Either SolveError
                                            (ResolveTo (Slurp Argument)
                                                        Reference)
        fromAdjacentArgOrDefault = do

          -- (flag, ...flags) -> (...flags, flag)
          (Tuple fs f) <- do
            pure case A.last (o.stack) of
              Just f' -> Tuple (o.flag A.: (unsafePartial
                                            $ fromJust
                                            $ A.init o.stack)) f'
              Nothing -> Tuple [] o.flag

          -- Look the trailing option up in the descriptions
          -- and combine it into the most complete option we
          -- can know about at this point.
          descMatch <- matchDesc true f
          matches   <- (Option <$> _) <$> (matchDesc false `traverse` fs)

          -- Check to see if this option has an explicitly bound argument.
          -- In this case, a check to consume an adjacent arg must not take
          -- place.
          case o.arg of
            (Just exarg) -> do
              -- Note: There is no check to see if an explicit argument is
              --       the same as specified in the option descriptions for
              --       convenience to the user.
              pure $ Resolved $ Keep
                    $ (fromFoldable matches)
                      <> (singleton $ Option descMatch)

            Nothing ->
              -- Look ahead if any of the following arguments should be slurped.
              -- Return either `Nothing` to signify that nothing should be
              -- slurped or a value signifieng that it should be slurped, and
              -- the `isRepeated` flag should be inherited.
              let
                adjArgMatch = do
                  guard (not o.repeatable)
                  (arg@{ name }) <- unOptionArgument <$> descMatch.arg
                  adjArg <- mAdjArg
                  (r /\ n /\ optional) <- case adjArg of
                    (U.Positional pos) -> pure (pos.repeatable /\ pos.name /\ false)
                    (U.Command    cmd) -> pure (cmd.repeatable /\ cmd.name /\ false)
                    (U.Group { branches: (x : Nil) : Nil, optional, repeatable }) ->
                      case x of
                        (U.Positional pos) ->
                          pure ((pos.repeatable || repeatable) /\ pos.name /\ optional)
                        (U.Command    cmd) ->
                          pure ((cmd.repeatable || repeatable) /\ cmd.name /\ optional)
                        otherwise -> Nothing
                    otherwise -> Nothing
                  pure do
                    guardArgs n name
                    pure (r /\ arg { optional = optional })

              in case adjArgMatch of
                Nothing -> do
                  if not (fromMaybe true
                           $ _.optional <<< unOptionArgument <$> descMatch.arg)
                    then fail
                        $ "Option-Argument specified in options-section missing"
                          <> " -" <> String.singleton f
                    else do
                      pure $ Resolved $ Keep
                        $ (fromFoldable matches)
                          <> (singleton $ Option descMatch)
                Just matched -> do
                  (r /\ arg) <- matched
                  pure $ Resolved $ Slurp
                    $ (flip setRepeatable r <$> fromFoldable matches)
                      <> (singleton
                            $ Option $ descMatch  { arg = pure (OptionArgument arg)
                                                  , repeatable = r
                                                  })

        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^=^ n' = pure true
        guardArgs n n' = fail
          $ "Arguments mismatch for option -" <> String.singleton o.flag <> ": "
              <> show n <> " and " <> show n'

        -- | Match a given flag with an option description.
        -- | `isTrailing` indicates if this flag is the last flag
        -- | in it's stack of flags.

        matchDesc :: Boolean -> Char -> Either SolveError OptionObj
        matchDesc isTrailing f =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
                    $ "Multiple option descriptions for option -"
                        <> String.singleton f

            (Desc.OptionDesc desc):Nil -> do
              arg <- if isTrailing
                          then resolveOptArg o.arg desc.arg
                          else if isNothing desc.arg
                            then pure Nothing
                            else fail
                              $ "Stacked option -" <> String.singleton f
                                  <> " may not specify arguments"
              pure  { aliases:    desc.aliases
                    , arg:        OptionArgument <$> arg
                    , env:        desc.env
                    , repeatable: o.repeatable
                    }

            -- default fallback: construct the option from itself alone
            otherwise ->
              pure  { aliases:    (Short f) :| Nil
                    , env:        Nothing
                    , arg:        OptionArgument <$>
                                    if isTrailing
                                      then convertArg o.arg
                                      else Nothing
                    , repeatable: o.repeatable
                    }

          where
            isMatch (Desc.OptionDesc { aliases }) = flip any aliases case _ of
              OptionAlias.Short f' -> f' == f
              _                    -> false
            isMatch _ = false

    -- | Resolve an option's argument name against that given in the
    -- | description, pureing the most complete argument known.
    resolveOptArg :: Maybe { name :: String, optional :: Boolean }
                  -> Maybe Desc.OptionArgumentObj
                  -> Either SolveError (Maybe OptionArgumentObj)

    resolveOptArg (Just a) Nothing = do
      pure <<< pure $ { name:     a.name
                      , optional: a.optional
                      , default:  Nothing }

    resolveOptArg Nothing (Just de) = do
      pure <<< pure $ { name:     de.name
                      , optional: de.optional
                      , default:  de.default }

    resolveOptArg (Just a) (Just de) = do
      pure <<< pure
        $ { name:     de.name
          , optional: de.optional || a.optional
          , default:  de.default
          }

    resolveOptArg _ _ = pure Nothing

    convertArg :: Maybe { name :: String, optional :: Boolean }
               -> Maybe OptionArgumentObj
    convertArg arg = do
      a <- arg
      pure  { name:     a.name
            , optional: a.optional
            , default:  Nothing }

solveUsage
  :: SpecParser.Usage
  -> List SpecParser.Desc
  -> Either SolveError Usage
solveUsage bs ds = traverse (flip solveBranch ds) bs

solve
  :: List SpecParser.Usage
  -> List SpecParser.Desc
  -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Array as A
import Data.String as S
import Data.String.Unsafe as US
import Control.Alt ((<|>))
import Control.MonadPlus (guard)
import Control.MonadPlus.Partial (mpartition)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either, fromRight)
import Data.Foldable (any, elem)
import Data.Function (on)
import Data.Functor ((<$))
import Data.List (findIndex, groupBy, List(..), length, filter, singleton,
                  fromFoldable, catMaybes, head, (:), concat, reverse)
import Data.Maybe (fromMaybe, Maybe(Nothing, Just), isNothing, maybe, isJust,
                  fromJust)
import Data.String (fromCharArray, toCharArray, toUpper)
import Data.String (singleton) as String
import Data.String.Ext ((^=), endsWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String as Str
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.NonEmpty as NonEmpty

import Language.Docopt.Argument
import Language.Docopt.Argument (isFree) as Arg
import Language.Docopt.OptionAlias (Aliases(), OptionAlias(..))
import Language.Docopt.OptionAlias (OptionAlias(..)) as OptionAlias
import Language.Docopt.SpecParser.Desc as Desc
import Language.Docopt.Argument (Argument(..), Branch, OptionArgument(..))
import Language.Docopt.Errors (SolveError(..))
import Language.Docopt.SpecParser (Desc(), Usage()) as SpecParser
import Language.Docopt.SpecParser.Usage.Argument (Branch, Argument(..)) as U
import Language.Docopt.Usage (Usage)
import Partial.Unsafe (unsafePartial)

foreign import undefined :: forall a. a

type Reference = String -- [options] reference

data Slurp a
  = Slurp (List a) -- slurp the adjacent argument
  | Keep  (List a) -- keep  the adjacent argument

data ResolveTo a b
  = Resolved   a
  | Unresolved b

posArgsEq :: String -> String -> Boolean
posArgsEq = eq `on` (Str.toUpper <<< stripAngles)
infixl 9 posArgsEq as ^=^

stripAngles :: String -> String
stripAngles = stripPrefix <<< stripSuffix
  where
  stripPrefix s = fromMaybe s (Str.stripPrefix "<" s)
  stripSuffix s = fromMaybe s (Str.stripSuffix ">" s)

instance showResolveTo :: (Show a, Show b) => Show (ResolveTo a b) where
  show (Resolved   a) = "Resolved "   <> show a
  show (Unresolved b) = "Unresolved " <> show b

fail :: forall a. String -> Either SolveError a
fail = Left <<< SolveError

solveBranch
  :: U.Branch                 -- ^ the usage branch
  -> List SpecParser.Desc     -- ^ the option descriptions
  -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go args = do
      solved <- solveArgs args
      pure do
        clump <- groupFree solved
        case partition clump of
          Tuple surroundingArgs _ -> do
            x <- clump
            case x of
              Resolved x   -> pure x
              Unresolved _ -> expand ds surroundingArgs

      where
        groupFree
          :: List (ResolveTo Argument Reference)
          -> List (List (ResolveTo Argument Reference))
        groupFree = groupBy (eq `on` isFree)

        partition
          :: forall a b
           . List (ResolveTo a b)
          -> Tuple (List a) (List b)
        partition = f <<< mpartition isResolved
          where f = bimap (\x -> concat $ x <#> \a -> case a of
                            (Resolved x) -> pure x
                            otherwise    -> Nil
                          )
                          (\x -> concat $ x <#> \a -> case a of
                            (Unresolved x) -> pure x
                            otherwise      -> Nil
                          )

        expand
          :: List SpecParser.Desc
          -> List Argument
          -> List Argument
        expand ds surroundingArgs = reverse $ go ds surroundingArgs Nil
          where
          go :: List SpecParser.Desc -> List Argument -> List Argument -> List Argument
          go ((x@(Desc.OptionDesc desc)):xs) surroundingArgs acc = do
            -- Assuming description and usage have already been merged,
            -- find all options that are not present in the surrounding
            -- "free" area and add them.
            if isJust (findIndex (isMatch desc.aliases) surroundingArgs)
                then go xs surroundingArgs acc
                else
                  let z = Group {
                          optional: true
                        , branches: (singleton $ singleton $ Option $
                              { aliases:    desc.aliases
                              , arg:        OptionArgument <$> desc.arg
                              , env:        desc.env
                              , repeatable: false
                              }
                          )
                        , repeatable: desc.repeatable
                        }
                  in go xs (z:surroundingArgs) (z:acc)
            where
              isMatch aliases (Option o)  = any (_ `elem` aliases) o.aliases
              isMatch aliases (Group grp) = any (isMatch aliases) (concat grp.branches)
              isMatch _ _                 = false

          go (_:xs) surroundingArgs acc = go xs surroundingArgs acc
          go _ _ acc = acc

        isFree :: forall b . ResolveTo Argument b -> Boolean
        isFree (Resolved a)   = Arg.isFree a
        isFree (Unresolved _) = true

        isResolved :: forall a b . ResolveTo a b -> Boolean
        isResolved (Resolved _) = true
        isResolved _            = false

    solveArgs :: U.Branch -> Either SolveError
                                    (List (ResolveTo Argument
                                                     Reference))
    solveArgs Nil = pure Nil
    solveArgs (x:Nil) = do
      m <- solveArg x Nothing
      pure case m of
           Resolved (Slurp xs) -> Resolved <$> xs
           Resolved (Keep xs)  -> Resolved <$> xs
           Unresolved a        -> singleton $ Unresolved a
    solveArgs (x:y:xs) = do
      m <- solveArg x (Just y)
      case m of
           Resolved (Keep  zs) -> ((Resolved <$> zs) <> _) <$> solveArgs (y:xs)
           Resolved (Slurp zs) -> ((Resolved <$> zs) <> _) <$> solveArgs xs
           Unresolved a        -> ((singleton $ Unresolved a) <> _)
                                    <$> solveArgs (y:xs)

    simpleResolve v = Right $ Resolved $ Keep $ singleton v

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArg
      :: U.Argument
      -> Maybe U.Argument
      -> Either SolveError (ResolveTo (Slurp Argument) Reference)

    solveArg (U.Reference r) _ = pure $ Unresolved r
    solveArg (U.EOA) _         = simpleResolve EOA
    solveArg (U.Stdin) _       = simpleResolve Stdin

    solveArg (U.Command cmd) _ = simpleResolve
      $ Command {
          name:       cmd.name
        , repeatable: cmd.repeatable
        }

    solveArg (U.Positional pos) _ = simpleResolve
      $ Positional {
        name:       pos.name
      , repeatable: pos.repeatable
      }

    solveArg (U.Group grp) _ =
      Resolved <<< Keep <<< singleton <$> do
        branches <- flip solveBranch ds `traverse` grp.branches
        pure $ Group grp { branches = branches }

    solveArg (U.Option o) mAdjArg = do

      -- Find a matching option description, if any.
      descMatch <- matchDesc

      -- Check to see if this option has an explicitly bound argument.
      -- In this case, a check to consume an adjacent arg must not take place.
      case o.arg of
        (Just exarg) -> do
          -- Note: There is no check to see if an explicit argument is
          --       the same as specified in the option descriptions for
          --       convenience to the user.
          pure  $ Resolved
                $ Keep
                $ singleton
                $ Option descMatch

        Nothing -> do
          -- Look ahead if any of the following arguments should be slurped.
          -- Return either `Nothing` to signify that nothing should be slurped
          -- or a value signifieng that it should be slurped, and the
          -- `isRepeated` flag should be inherited.
          let
            adjArgMatch = do
              guard (not o.repeatable)
              (arg@{ name }) <- unOptionArgument <$> descMatch.arg
              adjArg <- mAdjArg
              (r /\ n /\ optional) <- case adjArg of
                (U.Positional pos) -> pure (pos.repeatable /\ pos.name /\ false)
                (U.Command    cmd) -> pure (cmd.repeatable /\ cmd.name /\ false)
                (U.Group { branches: (x : Nil) : Nil, optional, repeatable }) ->
                  case x of
                    (U.Positional pos) ->
                      pure ((pos.repeatable || repeatable) /\ pos.name /\ optional)
                    (U.Command    cmd) ->
                      pure ((cmd.repeatable || repeatable) /\ cmd.name /\ optional)
                    otherwise -> Nothing
                otherwise -> Nothing
              pure do
                guardArgs n name
                pure (r /\ arg { optional = optional })

          case adjArgMatch of
            Nothing -> do
              if not (fromMaybe true
                      $ (_.optional <<< unOptionArgument <$> descMatch.arg))
                 then do
                    fail
                      $ "Option-Argument specified in options-section missing"
                        <> " --" <> o.name
                  else
                    pure  $ Resolved
                          $ Keep
                          $ singleton
                          $ Option descMatch
            Just matched -> do
              (r /\ arg) <- matched
              pure  $ Resolved
                    $ Slurp
                    $ singleton
                    $ Option $ descMatch  { arg = pure (OptionArgument arg)
                                          , repeatable = r
                                          }

      where
        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^=^ n' = pure true
        guardArgs n n' = fail
          $ "Arguments mismatch for option --" <> o.name <> ": "
              <> show n <> " and " <> show n'

        matchDesc :: Either SolveError OptionObj
        matchDesc =
          case filter isMatch ds of

            xs | length xs > 1 -> fail
              $ "Multiple option descriptions for option --" <> o.name

            -- construct the option from itself and the matching description
            (Desc.OptionDesc desc) : Nil -> do
              arg <- resolveOptArg o.arg desc.arg
              pure  { aliases:    desc.aliases
                    , arg:        OptionArgument <$> arg
                    , env:        desc.env
                    , repeatable: o.repeatable
                    }

            -- default fallback: construct the option from itself alone
            otherwise ->
              pure  { aliases:    NonEmpty (OptionAlias.Long o.name) Nil
                    , env:        Nothing
                    , arg:        OptionArgument <$> convertArg o.arg
                    , repeatable: o.repeatable
                    }
          where
            isMatch (Desc.OptionDesc { aliases }) = flip any aliases case _ of
              OptionAlias.Long n -> n == o.name
              _                  -> false
            isMatch _ = false

    solveArg (U.OptionStack o) mAdjArg
      = fromSubsumption <|> fromAdjacentArgOrDefault

      where
        -- | Subsumption method:
        -- | (Only applies for options w/o explicit arg)
        -- |
        -- | Concatenate the option stack into a string,
        -- | then do a substring check for each possible description.
        -- |
        -- | "armmsg"
        -- |    ~~~~
        -- |    ^^
        -- |    |`- the arg  matches - case INSENSITIVE
        -- |    `-- the flag matches - case SENSITIVE
        -- |
        -- | Should this check yield a match, slice the matched
        -- | string off the stack and return the remainder option
        -- | stack (if any).
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromSubsumption :: Either SolveError
                                  (ResolveTo (Slurp Argument)
                                              Reference)
        fromSubsumption = do

          -- XXX: Well, this error should not be thrown, but rather,
          --      we should just not come to this code-path if this is
          --      the case. It would be an awkward user-facing error.
          if isJust o.arg
            then fail $ "Option stacks with explicit argument binding "
                     <> "may not be subsumed."
            else pure unit

          let fs  = fromCharArray $ o.flag A.: o.stack

          maybe (fail "No description subsumed option") pure do
            -- XXX: Purescript is not lazy, so this is too expensive.
            --      We can just stop at the first `Just` value.
            head $ catMaybes $ ds <#> case _ of
              (Desc.OptionDesc d) -> do
                head $ catMaybes $ fromFoldable $ d.aliases <#> case _ of
                  (OptionAlias.Short f) -> subsume f fs d
                  _                     -> Nothing
              _ -> Nothing

          where
            subsume
              :: Char
              -> String
              -> _
              -> Maybe (ResolveTo (Slurp Argument)
                       Reference)
            subsume f fs d = do
              a <- d.arg

              -- the haystack needs to be modified, such that the
              -- the last (length a.name) characters are uppercased
              -- and hence compared case INSENSITIVELY.
              let bareArgname = stripAngles a.name
                  needle      = toUpper $ String.singleton f <> bareArgname
                  haystack    = toUpper fs

              (Tuple fs o) <- if endsWith needle haystack
                then
                  let ix = S.length haystack - S.length needle
                   in if unsafePartial (US.charAt ix fs) == f
                        then pure
                          $ Tuple (toCharArray
                                    (S.take (S.length fs
                                              - S.length bareArgname
                                              - 1
                                            ) fs
                                    )
                                  )
                                  { aliases:    d.aliases
                                  , arg:        pure a
                                  , env:        d.env
                                  , repeatable: o.repeatable
                                  }
                    else Nothing
                else Nothing

              cs <- either (const Nothing)
                           (pure <<< id)
                           (matchDesc false `traverse` fs)

              -- set the same repeatability flag for each stacked option as
              -- indicated by trailing option.
              let cs' = flip setRepeatable o.repeatable <$> do
                          Option <$> fromFoldable cs

              pure  $ Resolved
                    $ Keep
                    $ cs' <> (singleton $ Option $ o {
                      arg = OptionArgument <$> o.arg
                    })

        -- | Last flag method (w/ fallback):
        -- |
        -- | Find the last char in the option stack, look it up
        -- | in the descriptions and when it was found to have an
        -- | argument, that matches the adjacent argument (or it's
        -- | explicit binding), consume that argument and produce
        -- | a list of remaining short options.
        -- |
        -- | "armmsg=ARG"
        -- | OR:
        -- | "armmsg ARG"
        -- |       ~ ~~~
        -- |       ^  ^
        -- |       |  `-- only slurped if description found and
        -- |       |      has matching argument.
        -- |       `----- look for a description of `-g``
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromAdjacentArgOrDefault :: Either SolveError
                                            (ResolveTo (Slurp Argument)
                                                        Reference)
        fromAdjacentArgOrDefault = do

          -- (flag, ...flags) -> (...flags, flag)
          (Tuple fs f) <- do
            pure case A.last (o.stack) of
              Just f' -> Tuple (o.flag A.: (unsafePartial
                                            $ fromJust
                                            $ A.init o.stack)) f'
              Nothing -> Tuple [] o.flag

          -- Look the trailing option up in the descriptions
          -- and combine it into the most complete option we
          -- can know about at this point.
          descMatch <- matchDesc true f
          matches   <- (Option <$> _) <$> (matchDesc false `traverse` fs)

          -- Check to see if this option has an explicitly bound argument.
          -- In this case, a check to consume an adjacent arg must not take
          -- place.
          case o.arg of
            (Just exarg) -> do
              -- Note: There is no check to see if an explicit argument is
              --       the same as specified in the option descriptions for
              --       convenience to the user.
              pure $ Resolved $ Keep
                    $ (fromFoldable matches)
                      <> (singleton $ Option descMatch)

            Nothing ->
              -- Look ahead if any of the following arguments should be slurped.
              -- Return either `Nothing` to signify that nothing should be
              -- slurped or a value signifieng that it should be slurped, and
              -- the `isRepeated` flag should be inherited.
              let
                adjArgMatch = do
                  guard (not o.repeatable)
                  (arg@{ name }) <- unOptionArgument <$> descMatch.arg
                  adjArg <- mAdjArg
                  (r /\ n /\ optional) <- case adjArg of
                    (U.Positional pos) -> pure (pos.repeatable /\ pos.name /\ false)
                    (U.Command    cmd) -> pure (cmd.repeatable /\ cmd.name /\ false)
                    (U.Group { branches: (x : Nil) : Nil, optional, repeatable }) ->
                      case x of
                        (U.Positional pos) ->
                          pure ((pos.repeatable || repeatable) /\ pos.name /\ optional)
                        (U.Command    cmd) ->
                          pure ((cmd.repeatable || repeatable) /\ cmd.name /\ optional)
                        otherwise -> Nothing
                    otherwise -> Nothing
                  pure do
                    guardArgs n name
                    pure (r /\ arg { optional = optional })

              in case adjArgMatch of
                Nothing -> do
                  if not (fromMaybe true
                           $ _.optional <<< unOptionArgument <$> descMatch.arg)
                    then fail
                        $ "Option-Argument specified in options-section missing"
                          <> " -" <> String.singleton f
                    else do
                      pure $ Resolved $ Keep
                        $ (fromFoldable matches)
                          <> (singleton $ Option descMatch)
                Just matched -> do
                  (r /\ arg) <- matched
                  pure $ Resolved $ Slurp
                    $ (flip setRepeatable r <$> fromFoldable matches)
                      <> (singleton
                            $ Option $ descMatch  { arg = pure (OptionArgument arg)
                                                  , repeatable = r
                                                  })

        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^=^ n' = pure true
        guardArgs n n' = fail
          $ "Arguments mismatch for option -" <> String.singleton o.flag <> ": "
              <> show n <> " and " <> show n'

        -- | Match a given flag with an option description.
        -- | `isTrailing` indicates if this flag is the last flag
        -- | in it's stack of flags.

        matchDesc :: Boolean -> Char -> Either SolveError OptionObj
        matchDesc isTrailing f =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
                    $ "Multiple option descriptions for option -"
                        <> String.singleton f

            (Desc.OptionDesc desc):Nil -> do
              arg <- if isTrailing
                          then resolveOptArg o.arg desc.arg
                          else if isNothing desc.arg
                            then pure Nothing
                            else fail
                              $ "Stacked option -" <> String.singleton f
                                  <> " may not specify arguments"
              pure  { aliases:    desc.aliases
                    , arg:        OptionArgument <$> arg
                    , env:        desc.env
                    , repeatable: o.repeatable
                    }

            -- default fallback: construct the option from itself alone
            otherwise ->
              pure  { aliases:    (Short f) :| Nil
                    , env:        Nothing
                    , arg:        OptionArgument <$>
                                    if isTrailing
                                      then convertArg o.arg
                                      else Nothing
                    , repeatable: o.repeatable
                    }

          where
            isMatch (Desc.OptionDesc { aliases }) = flip any aliases case _ of
              OptionAlias.Short f' -> f' == f
              _                    -> false
            isMatch _ = false

    -- | Resolve an option's argument name against that given in the
    -- | description, pureing the most complete argument known.
    resolveOptArg :: Maybe { name :: String, optional :: Boolean }
                  -> Maybe Desc.OptionArgumentObj
                  -> Either SolveError (Maybe OptionArgumentObj)

    resolveOptArg (Just a) Nothing = do
      pure <<< pure $ { name:     a.name
                      , optional: a.optional
                      , default:  Nothing }

    resolveOptArg Nothing (Just de) = do
      pure <<< pure $ { name:     de.name
                      , optional: de.optional
                      , default:  de.default }

    resolveOptArg (Just a) (Just de) = do
      pure <<< pure
        $ { name:     de.name
          , optional: de.optional || a.optional
          , default:  de.default
          }

    resolveOptArg _ _ = pure Nothing

    convertArg :: Maybe { name :: String, optional :: Boolean }
               -> Maybe OptionArgumentObj
    convertArg arg = do
      a <- arg
      pure  { name:     a.name
            , optional: a.optional
            , default:  Nothing }

solveUsage
  :: SpecParser.Usage
  -> List SpecParser.Desc
  -> Either SolveError Usage
solveUsage bs ds = traverse (flip solveBranch ds) bs

solve
  :: List SpecParser.Usage
  -> List SpecParser.Desc
  -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us


Fix BaseServer

Fix BaseServer

module BaseServer where

import BaseCommon
import Control.Monad.RWS
import Control.Monad.RWS.Trans
import Data.Maybe
import Data.Tuple
import Effect.Console
import Prelude
import Types
import Utils

import Control.Monad (when)
import Control.Monad.Reader.Class as R
import Control.Monad.Writer.Class as W
import Data.Array (head, null, filter, (\\))
import Data.Either as E
import Data.Foldable (for_, find)
import Data.Lens (lens, Lens')
import Data.Lens.At (at)
import Data.Lens.Getter ((^.))
import Data.Lens.Setter ((%~), (.~))
import Data.List as List
import Data.Generic.Rep (class Generic)
import Data.Argonaut.Encode.Generic.Rep (class EncodeRep)
import Data.Argonaut.Decode.Generic.Rep (class DecodeRep)
import Data.Map as M
import Data.String as S
import Effect (Effect)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Effect.Timer (setInterval)
import Global.Unsafe (unsafeDecodeURIComponent)
import NodeWebSocket as WS

idleInterval = 30 * 1000

type Server st =
  { connections :: Array Connection
  , state       :: st
  , timeCounter :: Int -- for tracking whether players are idle
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })
timeCounter = lens (\s -> s.timeCounter) (\s x -> s { timeCounter = x })

newtype Connection =
  Connection
    { wsConn      :: WS.Connection
    , pId         :: PlayerId
    , name        :: String
    , timeCounter :: Int -- for tracking whether the player is idle
    }

cWsConn = lens
  (\(Connection c) -> c.wsConn)
  (\(Connection c) x -> Connection $ c { wsConn = x })

cPId = lens
  (\(Connection c) -> c.pId)
  (\(Connection c) x -> Connection $ c { pId = x })

cName = lens
  (\(Connection c) -> c.name)
  (\(Connection c) x -> Connection $ c { name = x })

cTimeCounter = lens
  (\(Connection c) -> c.timeCounter)
  (\(Connection c) x -> Connection $ c { timeCounter = x })

connectionsToPlayersMap :: Array Connection -> M.Map PlayerId String
connectionsToPlayersMap =
  map (\(Connection c) -> Tuple c.pId c.name) >>> M.fromFoldable

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: Array outg
    , toOne :: M.Map PlayerId (Array outg)
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  append (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: M.unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

type ServerM st outg a =
  RWS (Array Connection) (SendMessages outg) st a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st outg a.
  Array Connection -> st -> ServerM st outg a -> ServerMResult st outg a
runServerM conns state action =
  case runRWS action conns state of
    RWSResult nextState result messages ->
      { nextState
      , messages
      , result
      }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  , timeCounter: 0
  }

runCallback :: forall st outg rep.
  Generic outg rep =>
  EncodeRep rep =>
  Ref (Server st) -> ServerM st outg Unit
  -> Effect Unit
runCallback refSrv callback = do
  srv <- Ref.read refSrv
  let res = runServerM srv.connections srv.state callback
  sendAllMessages srv res.messages
  Ref.write (srv { state = res.nextState }) refSrv

messagesFor :: forall outg. PlayerId -> SendMessages outg -> Array outg
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall st outg rep.
  Generic outg rep =>
  EncodeRep rep =>
  Server st -> SendMessages outg
  -> Effect Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor (conn ^. cPId) sm
    in when (not (null msgs)) $ do
      for_ msgs $ \msg ->
        WS.send (conn ^. cWsConn) (encode msg)

sendUpdate :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  Array outg -> m Unit
sendUpdates ms =
  W.tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  W.tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

askPlayers :: forall m.
  Monad m =>
  R.MonadReader (Array Connection) m =>
  m (M.Map PlayerId String)
askPlayers =
  connectionsToPlayersMap <$> R.ask

stepsPerSecond = 30

startServer :: forall st inc rep1 rep2 outg e.
  Generic inc rep1 =>
  DecodeRep rep1 =>
  Generic outg rep2 =>
  EncodeRep rep2 =>
  ServerCallbacks st inc outg -> Ref (Server st)
  -> Effect WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    log "got a request"
    let playerName = unsafeDecodeURIComponent (S.drop 1 (WS.resourceUrl req).search)

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            log $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            handleNewPlayer refSrv pId
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg -> do
              updatePlayerTimeCounter refSrv pId
              case decode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> log (show err)

            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId

          Nothing -> do
            log "rejecting connection, no player ids available"
            WS.close conn

  void $ setInterval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  void $ setInterval idleInterval $ do
    void $ kickIdlePlayers refSrv
    void $ updateServerTimeCounter refSrv

  pure server

tryAddPlayer conn refSrv name = do
  srv <- Ref.read refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [Connection { pId: pId
                                          , wsConn: conn
                                          , name: name
                                          , timeCounter: srv.timeCounter
                                          }] }
      Ref.write srv' refSrv
      pure (Just pId)
    Nothing ->
      pure Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c ^. cPId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleNewPlayer :: forall st.
  Ref (Server st) -> PlayerId -> Effect Unit
handleNewPlayer refSrv pId = do
  srv <- Ref.read refSrv
  let playersMap = connectionsToPlayersMap srv.connections
  let msgAll = NewPlayer playersMap
  let msgOne = YourPlayerIdIs pId
  let msgs = SendMessages { toAll: [msgAll]
                          , toOne: M.singleton pId [msgOne]
                          }
  log $ "new player connected, sending to all: " <> encode msgAll
  log $ "                      sending to one: " <> encode msgOne
  sendAllMessages srv msgs

closeConnection :: forall st.
  Ref (Server st) -> PlayerId -> Effect Unit
closeConnection refSrv pId = do
  void $ Ref.modify (connections %~ filter (\c -> pId /= c ^. cPId)) refSrv
  log $ "closed connection for " <> show pId

updatePlayerTimeCounter refSrv pId = do
  srv <- Ref.read refSrv
  let mConn = find (\c -> c ^. cPId == pId) srv.connections
  whenJust mConn $ \conn -> do
    let conn' = conn # cTimeCounter .~ srv.timeCounter
    let conns' = filter (\c -> pId /= c ^. cPId) srv.connections
    let conns'' = conns' <> [conn']
    void $ Ref.modify (connections .~ conns'') refSrv

kickIdlePlayers refSrv = do
  srv <- Ref.read refSrv
  let idles = filter (\c -> c ^. cTimeCounter /= srv.timeCounter)
                     srv.connections
  for_ idles $ \c -> do
    WS.close (c ^. cWsConn)

updateServerTimeCounter =
  Ref.modify (timeCounter %~ ((+) 1))

module BaseServer where

import BaseCommon
import Control.Monad.RWS
import Control.Monad.RWS.Trans
import Data.Maybe
import Data.Tuple
import Effect.Console
import Prelude
import Types
import Utils

import Control.Monad (when)
import Control.Monad.Reader.Class as R
import Control.Monad.Writer.Class as W
import Data.Array (head, null, filter, (\\))
import Data.Either as E
import Data.Foldable (for_, find)
import Data.Lens (lens, Lens')
import Data.Lens.At (at)
import Data.Lens.Getter ((^.))
import Data.Lens.Setter ((%~), (.~))
import Data.List as List
import Data.Generic.Rep (class Generic)
import Data.Argonaut.Encode.Generic.Rep (class EncodeRep)
import Data.Argonaut.Decode.Generic.Rep (class DecodeRep)
import Data.Map as M
import Data.String as S
import Effect (Effect)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Effect.Timer (setInterval)
import Global.Unsafe (unsafeDecodeURIComponent)
import NodeWebSocket as WS

idleInterval = 30 * 1000

type Server st =
  { connections :: Array Connection
  , state       :: st
  , timeCounter :: Int -- for tracking whether players are idle
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })
timeCounter = lens (\s -> s.timeCounter) (\s x -> s { timeCounter = x })

newtype Connection =
  Connection
    { wsConn      :: WS.Connection
    , pId         :: PlayerId
    , name        :: String
    , timeCounter :: Int -- for tracking whether the player is idle
    }

cWsConn = lens
  (\(Connection c) -> c.wsConn)
  (\(Connection c) x -> Connection $ c { wsConn = x })

cPId = lens
  (\(Connection c) -> c.pId)
  (\(Connection c) x -> Connection $ c { pId = x })

cName = lens
  (\(Connection c) -> c.name)
  (\(Connection c) x -> Connection $ c { name = x })

cTimeCounter = lens
  (\(Connection c) -> c.timeCounter)
  (\(Connection c) x -> Connection $ c { timeCounter = x })

connectionsToPlayersMap :: Array Connection -> M.Map PlayerId String
connectionsToPlayersMap =
  map (\(Connection c) -> Tuple c.pId c.name) >>> M.fromFoldable

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: Array outg
    , toOne :: M.Map PlayerId (Array outg)
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  append (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: M.unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

type ServerM st outg a =
  RWS (Array Connection) (SendMessages outg) st a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st outg a.
  Array Connection -> st -> ServerM st outg a -> ServerMResult st outg a
runServerM conns state action =
  case runRWS action conns state of
    RWSResult nextState result messages ->
      { nextState
      , messages
      , result
      }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  , timeCounter: 0
  }

runCallback :: forall st outg rep.
  Generic outg rep =>
  EncodeRep rep =>
  Ref (Server st) -> ServerM st outg Unit
  -> Effect Unit
runCallback refSrv callback = do
  srv <- Ref.read refSrv
  let res = runServerM srv.connections srv.state callback
  sendAllMessages srv res.messages
  Ref.write (srv { state = res.nextState }) refSrv

messagesFor :: forall outg. PlayerId -> SendMessages outg -> Array outg
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall st outg rep.
  Generic outg rep =>
  EncodeRep rep =>
  Server st -> SendMessages outg
  -> Effect Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor (conn ^. cPId) sm
    in when (not (null msgs)) $ do
      for_ msgs $ \msg ->
        WS.send (conn ^. cWsConn) (encode msg)

sendUpdate :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  Array outg -> m Unit
sendUpdates ms =
  W.tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg.
  Monad m =>
  W.MonadWriter (SendMessages outg) m =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  W.tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

askPlayers :: forall m.
  Monad m =>
  R.MonadReader (Array Connection) m =>
  m (M.Map PlayerId String)
askPlayers =
  connectionsToPlayersMap <$> R.ask

stepsPerSecond = 30

startServer :: forall st inc rep1 rep2 outg e.
  Generic inc rep1 =>
  DecodeRep rep1 =>
  Generic outg rep2 =>
  EncodeRep rep2 =>
  ServerCallbacks st inc outg -> Ref (Server st)
  -> Effect WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    log "got a request"
    let playerName = unsafeDecodeURIComponent (S.drop 1 (WS.resourceUrl req).search)

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            log $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            handleNewPlayer refSrv pId
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg -> do
              updatePlayerTimeCounter refSrv pId
              case decode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> log (show err)

            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId

          Nothing -> do
            log "rejecting connection, no player ids available"
            WS.close conn

  void $ setInterval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  void $ setInterval idleInterval $ do
    void $ kickIdlePlayers refSrv
    void $ updateServerTimeCounter refSrv

  pure server

tryAddPlayer conn refSrv name = do
  srv <- Ref.read refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [Connection { pId: pId
                                          , wsConn: conn
                                          , name: name
                                          , timeCounter: srv.timeCounter
                                          }] }
      Ref.write srv' refSrv
      pure (Just pId)
    Nothing ->
      pure Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c ^. cPId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleNewPlayer :: forall st.
  Ref (Server st) -> PlayerId -> Effect Unit
handleNewPlayer refSrv pId = do
  srv <- Ref.read refSrv
  let playersMap = connectionsToPlayersMap srv.connections
  let msgAll = NewPlayer playersMap
  let msgOne = YourPlayerIdIs pId
  let msgs = SendMessages { toAll: [msgAll]
                          , toOne: M.singleton pId [msgOne]
                          }
  -- log $ "new player connected, sending to all: " <> encode msgAll
  -- log $ "                      sending to one: " <> encode msgOne
  -- sendAllMessages srv msgs
  -- FIXME
  pure unit

closeConnection :: forall st.
  Ref (Server st) -> PlayerId -> Effect Unit
closeConnection refSrv pId = do
  void $ Ref.modify (connections %~ filter (\c -> pId /= c ^. cPId)) refSrv
  log $ "closed connection for " <> show pId

updatePlayerTimeCounter refSrv pId = do
  srv <- Ref.read refSrv
  let mConn = find (\c -> c ^. cPId == pId) srv.connections
  whenJust mConn $ \conn -> do
    let conn' = conn # cTimeCounter .~ srv.timeCounter
    let conns' = filter (\c -> pId /= c ^. cPId) srv.connections
    let conns'' = conns' <> [conn']
    void $ Ref.modify (connections .~ conns'') refSrv

kickIdlePlayers refSrv = do
  srv <- Ref.read refSrv
  let idles = filter (\c -> c ^. cTimeCounter /= srv.timeCounter)
                     srv.connections
  for_ idles $ \c -> do
    WS.close (c ^. cWsConn)

updateServerTimeCounter =
  Ref.modify (timeCounter %~ ((+) 1))


Add findIndex

Add findIndex

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , length
  , findIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import elemIndex
  "function elemIndex (e) {\
  \  return function (l) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import elemLastIndex
  "function elemLastIndex (e) {\
  \  return function (l) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , length
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import elemIndex
  "function elemIndex (e) {\
  \  return function (l) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import elemLastIndex
  "function elemLastIndex (e) {\
  \  return function (l) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append