Simplify

Simplify

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

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

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat)
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Foldable (foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)
import Data.Map (Map())
import qualified Data.Map as Map

import qualified Text.Parsing.Parser             as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos         as P
import qualified Text.Parsing.Parser.String      as P

import qualified Language.Docopt.Errors   as D
import qualified Language.Docopt.Value    as D
import qualified Language.Docopt.Argument as D
import qualified Language.Docopt.Usage    as D
import qualified Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.Parser (List Token) a

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

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

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

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

  where

    takesArg = isJust a

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

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

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

    go _ _ = Left "Invalid token"

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

  where

    takesArg = isJust a
    def      = a >>= (\(O.Argument a) -> a.value)

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = do
  P.choice $ xs <#> \x -> Tuple x <$> genBranchParser x
  <* eof

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

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                       -> Parser (List (Tuple D.Argument D.Value))
    genExhaustiveParser Nil = pure empty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument
             -> Int
             -> Parser (List (Tuple D.Argument D.Value))
        draw pss@(Cons p ps') n | n >= 0 = (do
          xs <- genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a switch, an explicit argument *must* be provided.
          let ys = map (\(Tuple a _) -> a) $
                    filter
                      (\(Tuple a v) -> (D.takesArgument a)
                                    && (not $ D.isFlag a)
                                    && (D.isBoolValue v))
                      xs
          if (length ys > 0)
            then P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)
            else return unit

          xss <- if D.isRepeatable p
                      then draw pss (length pss)
                      else draw (ps') (length ps')
          return $ xs ++ xss
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))
        draw ps' n | (length ps' > 0) && (n < 0) = do
          let rest = filter
                      (\p -> (not $ D.isRepeatable p)
                          && (not $ D.hasDefault p))
                      (reverse ps')
          if (length rest > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> rest)
            else return empty
        draw _ _ = return empty

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _) = Right $ Pending p (singleton x)
    step (Free p) x@(D.Group _ bs _) | isFree x
      = Right $ Pending p (singleton x)

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

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

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

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

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

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

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

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
      where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      if o.repeatable then (some go) else (singleton <$> go)
      ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser o.name o.arg)
          , Tuple x <$> (mkSoptParser o.flag o.arg)
          ]

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

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

    -- Generate a parser for a argument `Group`
    genParser x@(D.Group optional bs repeated) = do
      concat <$>
        let mod    = if optional then P.option empty else \p -> p
            parser = if repeated then many go else singleton <$> go
         in mod parser
      where go = if length bs > 0
                    then P.choice $ P.try <<< genBranchParser <$> bs
                    else return empty

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

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

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

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat)
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Foldable (foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)
import Data.Map (Map())
import qualified Data.Map as Map

import qualified Text.Parsing.Parser             as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos         as P
import qualified Text.Parsing.Parser.String      as P

import qualified Language.Docopt.Errors   as D
import qualified Language.Docopt.Value    as D
import qualified Language.Docopt.Argument as D
import qualified Language.Docopt.Usage    as D
import qualified Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.Parser (List Token) a

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

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

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

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

  where

    takesArg = isJust a

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

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

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

    go _ _ = Left "Invalid token"

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

  where

    takesArg = isJust a
    def      = maybe Nothing (\(O.Argument { value: v }) -> v) a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (takesArg == false) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (takesArg == false) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = do
  P.choice $ xs <#> \x -> Tuple x <$> genBranchParser x
  <* eof

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

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                       -> Parser (List (Tuple D.Argument D.Value))
    genExhaustiveParser Nil = pure empty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument
             -> Int
             -> Parser (List (Tuple D.Argument D.Value))
        draw pss@(Cons p ps') n | n >= 0 = (do
          xs <- genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a switch, an explicit argument *must* be provided.
          let ys = map (\(Tuple a _) -> a) $
                    filter
                      (\(Tuple a v) -> (D.takesArgument a)
                                    && (not $ D.isFlag a)
                                    && (D.isBoolValue v))
                      xs
          if (length ys > 0)
            then P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)
            else return unit

          xss <- if D.isRepeatable p
                      then draw pss (length pss)
                      else draw (ps') (length ps')
          return $ xs ++ xss
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))
        draw ps' n | (length ps' > 0) && (n < 0) = do
          let rest = filter
                      (\p -> (not $ D.isRepeatable p)
                          && (not $ D.hasDefault p))
                      (reverse ps')
          if (length rest > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> rest)
            else return empty
        draw _ _ = return empty

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _) = Right $ Pending p (singleton x)
    step (Free p) x@(D.Group _ bs _) | isFree x
      = Right $ Pending p (singleton x)

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

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

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

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

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

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

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

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
      where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      if o.repeatable then (some go) else (singleton <$> go)
      ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser o.name o.arg)
          , Tuple x <$> (mkSoptParser o.flag o.arg)
          ]

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

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

    -- Generate a parser for a argument `Group`
    genParser x@(D.Group optional bs repeated) = do
      concat <$>
        let mod    = if optional then P.option empty else \p -> p
            parser = if repeated then many go else singleton <$> go
         in mod parser
      where go = if length bs > 0
                    then P.choice $ P.try <<< genBranchParser <$> bs
                    else return empty

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


Remove even further `P.try` and `($)` calls

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.Transformerless.State (State, evalState)
import Control.MonadPlus (guard)
import Data.Either (Either(..), fromRight)
import Data.Identity (Identity())
import Data.Foldable (foldMap)
import Data.List (List(..), many, catMaybes, toUnfoldable, (:), some)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String (singleton, toUpper, split, joinWith) as String
import Data.String.Regex (Regex(), regex)
import Data.String.Regex (parseFlags, replace) as Regex
import Partial.Unsafe (unsafePartial)
import Data.String.Ext ((^=), (~~))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..), Result(..),
                            runParserT, parseFailed, fail, runParser, unParserT) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill,
                                        option) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | Optimal: Faster P.skipSpaces since it does not accumulate into a list.
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit
    bind = bindP

-- | Optimal: Translate [[<anything>-]options] to @anything
-- | this saves us looking ahead repeatedly when parsing '['.
referenceRegex :: Regex
referenceRegex
  = unsafePartial $ fromRight $
      regex
        "\\[(([^\\]](?!\\s*-?\\s*options\\s*))*?.?)\\s*-?\\s*options\\s*(\\.\\.\\.)?\\s*\\]"
        (Regex.parseFlags "gmi")

-- | Optimal: Typeclass-less bind instance
-- | TODO: how to make the inner bind typeclass-less?
bindP p f = P.ParserT $ \s -> do
  (P.Result input result consumed pos) <- P.unParserT p s
  case result of
    Left err  -> pure (P.Result input (Left err) consumed pos)
    Right a -> do
      (P.Result input' result' consumed' pos') <- P.unParserT (f a) (P.PState input pos)
      pure (P.Result input' result' (consumed || consumed') pos')

data Mode = Usage | Descriptions

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

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

instance showMode :: Show Mode where
  show (Usage)        = "Usage"
  show (Descriptions) = "Descriptions"

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  -- perform a simple transformation to avoid 'manyTill' and safe some millis
  -- lexing. Hopefully this won't be necessary when purescript-parsing improves
  -- performance, a faster parsing library shows up or the purescript compiler
  -- improves in performance.
  let
    input' = if isUsageMode m
                then Regex.replace referenceRegex "@$1" input
                else input

  P.runParser input' (parseTokens m)

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

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

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

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

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

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

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

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

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " ~~ i
  pure xs
  where bind = bindP

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

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.char   '['   $> LSquare
  , _reference
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , _stdin
  , AngleName <$> _angleName
  , maybeShoutName
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , AngleName <$> _angleName
  , maybeShoutName
  , _tag
  , _reference
  , eol $> Newline
  , Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'
  where bind = bindP

maybeShoutName :: P.Parser String Token
maybeShoutName = do
  n <- _anyName
  pure if (String.toUpper n == n)
          then ShoutName n
          else Name n
  where bind = bindP

_anyName :: P.Parser String String
_anyName = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]
  where bind = bindP

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

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

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

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.char '@'
  foldMap String.singleton <$> many (P.noneOf [' ', '\n'])
  where bind = bindP

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  s <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
  case A.uncons (String.split ":" s) of
    Nothing -> pure (Tag s Nothing)
    Just { head: _, tail: xs } | A.length xs == 0 -> pure (Tag s Nothing)
    Just { head: x, tail: xs } ->
      let v = trim (String.joinWith ":" xs)
       in pure (Tag x (Just v))

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

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

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

  arg <- P.option Nothing $ P.choice [

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

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

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

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

  pure $ SOpt x xs arg
  where bind = bindP

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

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

  arg <- P.option Nothing $ P.choice [

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

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

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

  pure $ LOpt name' arg
  where bind = bindP

identStart :: P.Parser String Char
identStart = alpha

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

flag :: P.Parser String Char
flag = lowerAlphaNum

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

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

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

anyToken :: TokenParser Token
anyToken = token $ Just

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

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

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

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

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

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

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

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

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

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

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

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

module Language.Docopt.SpecParser.Lexer where

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

-- | Optimal: Faster P.skipSpaces since it does not accumulate into a list.
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit
    bind = bindP

-- | Optimal: Translate [[<anything>-]options] to @anything
-- | this saves us looking ahead repeatedly when parsing '['.
referenceRegex :: Regex
referenceRegex
  = unsafePartial $ fromRight $
      regex
        "\\[(([^\\]](?!\\s*-?\\s*options\\s*))*?.?)\\s*-?\\s*options\\s*(\\.\\.\\.)?\\s*\\]"
        (Regex.parseFlags "gmi")

-- | Optimal: Typeclass-less bind instance
-- | TODO: how to make the inner bind typeclass-less?
bindP p f = P.ParserT $ \s -> do
  (P.Result input result consumed pos) <- P.unParserT p s
  case result of
    Left err  -> pure (P.Result input (Left err) consumed pos)
    Right a -> do
      (P.Result input' result' consumed' pos') <- P.unParserT (f a) (P.PState input pos)
      pure (P.Result input' result' (consumed || consumed') pos')

data Mode = Usage | Descriptions

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

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

instance showMode :: Show Mode where
  show (Usage)        = "Usage"
  show (Descriptions) = "Descriptions"

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  -- perform a simple transformation to avoid 'manyTill' and safe some millis
  -- lexing. Hopefully this won't be necessary when purescript-parsing improves
  -- performance, a faster parsing library shows up or the purescript compiler
  -- improves in performance.
  let
    input' = if isUsageMode m
                then Regex.replace referenceRegex "@$1" input
                else input

  P.runParser input' (parseTokens m)

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

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

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

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

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

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

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

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

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " ~~ i
  pure xs
  where bind = bindP

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

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.char   '['   $> LSquare
  , _reference
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , _stdin
  , AngleName <$> _angleName
  , maybeShoutName
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try $ AngleName <$> _angleName
  , P.try maybeShoutName
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'
  where bind = bindP

maybeShoutName :: P.Parser String Token
maybeShoutName = do
  n <- _anyName
  pure if (String.toUpper n == n)
          then ShoutName n
          else Name n
  where bind = bindP

_anyName :: P.Parser String String
_anyName = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]
  where bind = bindP

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

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

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

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.char '@'
  foldMap String.singleton <$> many (P.noneOf [' ', '\n'])
  where bind = bindP

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  s <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
  case A.uncons (String.split ":" s) of
    Nothing -> pure (Tag s Nothing)
    Just { head: _, tail: xs } | A.length xs == 0 -> pure (Tag s Nothing)
    Just { head: x, tail: xs } ->
      let v = trim (String.joinWith ":" xs)
       in pure (Tag x (Just v))

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

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

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

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

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

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

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

  , pure Nothing
  ]

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

  pure $ SOpt x xs arg
  where bind = bindP

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

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

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

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

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

  , pure Nothing
  ]

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

  pure $ LOpt name' arg
  where bind = bindP

identStart :: P.Parser String Char
identStart = alpha

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

flag :: P.Parser String Char
flag = lowerAlphaNum

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

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

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

anyToken :: TokenParser Token
anyToken = token $ Just

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

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

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

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

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

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

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

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

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

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

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

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


Always enable mirroring (#1330)

Always enable mirroring (#1330)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.BackSide where

import SlamData.Prelude

import Data.List (List)

import SlamData.ActionList.Component as ActionList
import SlamData.Workspace.Deck.Component.State (CardDef)
import SlamData.Workspace.Deck.DeckId (DeckId)

data BackAction
  = Trash
  | Rename
  | Embed
  | Publish
  | DeleteDeck
  | Mirror
  | Wrap
  | Unwrap
  | Share
  | Unshare

derive instance eqBackAction ∷ Eq BackAction

type BackSideOptions =
  { deckId ∷ DeckId
  , displayCursor ∷ List DeckId
  }

allBackActions ∷ Boolean → Array BackAction
allBackActions isAdvanced =
  [ Trash
  , Rename
  ]
  ⊕ (if isAdvanced
      then [ Share
           , Unshare
           ]
      else [ ])
  ⊕ [ Embed
    , Publish
    , DeleteDeck
    , Mirror
    , Wrap
    , Unwrap
    ]

labelAction ∷ BackAction → ActionList.ActionName
labelAction =
  ActionList.ActionName
    ∘ case _ of
        Trash → "Delete card"
        Rename → "Rename deck"
        Share → "Share deck"
        Embed → "Embed deck"
        Publish → "Publish deck"
        DeleteDeck → "Delete deck"
        Mirror → "Mirror"
        Wrap → "Wrap"
        Unwrap → "Collapse"
        Unshare → "Unshare deck"

actionDescripton ∷ BackAction → ActionList.ActionDescription
actionDescripton =
  ActionList.ActionDescription
    ∘ case _ of
        Trash → "Delete card"
        Rename → "Rename deck"
        Share → "Share deck"
        Embed → "Embed deck"
        Publish → "Publish deck"
        DeleteDeck → "Delete deck"
        Mirror → "Mirror"
        Wrap → "Wrap"
        Unwrap → "Collapse"
        Unshare → "Unshare deck"

actionHighlighted ∷ Boolean → Maybe CardDef → Array CardDef → BackAction → ActionList.ActionHighlighted
actionHighlighted unwrappable activeCard cardDefs a =
  ActionList.ActionHighlighted
    $ case activeCard, a of
      Nothing, Trash → false
      _, Unwrap → unwrappable
      _, _ → true

actionIcon ∷ BackAction → ActionList.ActionIconSrc
actionIcon =
  ActionList.ActionIconSrc
    ∘ case _ of
        Trash → "img/cardAndDeckActions/deleteCard.svg"
        Rename → "img/cardAndDeckActions/renameDeck.svg"
        Share → "img/cardAndDeckActions/shareDeck.svg"
        Unshare → "img/cardAndDeckActions/unshareDeck.svg"
        Embed → "img/cardAndDeckActions/embedDeck.svg"
        Publish → "img/cardAndDeckActions/publishDeck.svg"
        Mirror → "img/cardAndDeckActions/mirrorDeck.svg"
        Wrap → "img/cardAndDeckActions/wrapDeck.svg"
        Unwrap → "img/cardAndDeckActions/unwrapDeck.svg"
        DeleteDeck → "img/cardAndDeckActions/deleteDeck.svg"

toActionListAction ∷ Boolean → Maybe CardDef → Array CardDef → BackAction → ActionList.Action BackAction
toActionListAction unwrappable activeCard cardDefs backAction =
   ActionList.Do
     (labelAction backAction)
     (actionIcon backAction)
     (actionDescripton backAction)
     (actionHighlighted unwrappable activeCard cardDefs backAction)
     backAction

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.BackSide where

import SlamData.Prelude

import Data.List (List)
import Data.Foldable as F

import SlamData.ActionList.Component as ActionList
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Deck.Component.State (CardDef)
import SlamData.Workspace.Deck.DeckId (DeckId)

data BackAction
  = Trash
  | Rename
  | Embed
  | Publish
  | DeleteDeck
  | Mirror
  | Wrap
  | Unwrap
  | Share
  | Unshare

derive instance eqBackAction ∷ Eq BackAction

type BackSideOptions =
  { deckId ∷ DeckId
  , displayCursor ∷ List DeckId
  }

allBackActions ∷ Boolean → Array BackAction
allBackActions isAdvanced =
  [ Trash
  , Rename
  ]
  ⊕ (if isAdvanced
      then [ Share
           , Unshare
           ]
      else [ ])
  ⊕ [ Embed
    , Publish
    , DeleteDeck
    , Mirror
    , Wrap
    , Unwrap
    ]

labelAction ∷ BackAction → ActionList.ActionName
labelAction =
  ActionList.ActionName
    ∘ case _ of
        Trash → "Delete card"
        Rename → "Rename deck"
        Share → "Share deck"
        Embed → "Embed deck"
        Publish → "Publish deck"
        DeleteDeck → "Delete deck"
        Mirror → "Mirror"
        Wrap → "Wrap"
        Unwrap → "Collapse"
        Unshare → "Unshare deck"

actionDescripton ∷ BackAction → ActionList.ActionDescription
actionDescripton =
  ActionList.ActionDescription
    ∘ case _ of
        Trash → "Delete card"
        Rename → "Rename deck"
        Share → "Share deck"
        Embed → "Embed deck"
        Publish → "Publish deck"
        DeleteDeck → "Delete deck"
        Mirror → "Mirror"
        Wrap → "Wrap"
        Unwrap → "Collapse"
        Unshare → "Unshare deck"

actionHighlighted ∷ Boolean → Maybe CardDef → Array CardDef → BackAction → ActionList.ActionHighlighted
actionHighlighted unwrappable activeCard cardDefs a =
  ActionList.ActionHighlighted
    $ case activeCard, a of
      Nothing, Trash → false
      _, Unwrap → unwrappable
      _, Mirror | F.elem CT.Draftboard (_.cardType <$> cardDefs) → false
      _, _ → true

actionIcon ∷ BackAction → ActionList.ActionIconSrc
actionIcon =
  ActionList.ActionIconSrc
    ∘ case _ of
        Trash → "img/cardAndDeckActions/deleteCard.svg"
        Rename → "img/cardAndDeckActions/renameDeck.svg"
        Share → "img/cardAndDeckActions/shareDeck.svg"
        Unshare → "img/cardAndDeckActions/unshareDeck.svg"
        Embed → "img/cardAndDeckActions/embedDeck.svg"
        Publish → "img/cardAndDeckActions/publishDeck.svg"
        Mirror → "img/cardAndDeckActions/mirrorDeck.svg"
        Wrap → "img/cardAndDeckActions/wrapDeck.svg"
        Unwrap → "img/cardAndDeckActions/unwrapDeck.svg"
        DeleteDeck → "img/cardAndDeckActions/deleteDeck.svg"

toActionListAction ∷ Boolean → Maybe CardDef → Array CardDef → BackAction → ActionList.Action BackAction
toActionListAction unwrappable activeCard cardDefs backAction =
   ActionList.Do
     (labelAction backAction)
     (actionIcon backAction)
     (actionDescripton backAction)
     (actionHighlighted unwrappable activeCard cardDefs backAction)
     backAction


compling

compling

module Component.Pong where

import Prelude
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Timer (clearInterval, interval, Interval, TIMER)
import Data.Int (ceil)
import Data.Maybe (Maybe(..))
import Graphics.Canvas (CANVAS)
import Halogen (ComponentDSL, ComponentHTML, Component, HalogenEffects, action, lifecycleComponent, liftH, get, modify)
import Pong (sendCommand, PongState, DirY(..), Move(..), Player(..), PongCommand(..), renderPong, initialPongState)

type State = { pong :: PongState, loop :: Maybe Interval}

initial :: State
initial = {pong: initialPongState, loop: Nothing}

data Query a = NewGame a | StopGame a | Move a | StepGame a

type PongEffects eff = (canvas :: CANVAS , timer :: TIMER | eff)

game :: forall g eff. (Functor g, MonadEff (HalogenEffects(PongEffects eff)) g) => Component State Query g
game = lifecycleComponent {render, eval, initializer: Just (action NewGame), finalizer: Just (action StopGame)}
            where
              render :: State -> ComponentHTML Query
              render _ = H.canvas [P.id_ canvasName
                                  , E.onKeyDown (E.input_ Move)
                                  , P.tabIndex 0
                                  , P.height $ P.Pixels $ ceil canvasSize.h
                                  , P.width
                                    $ P.Pixels
                                    $ ceil canvasSize.w ]

              eval :: Query ~> (ComponentDSL State Query g)
              eval (NewGame a) = do
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                int <- (liftH <<< liftEff $ startLoop)
                modify (\x -> x {loop = Just int})
                pure a
              eval (Move a) = do
                modify (\s -> s {pong = sendCommand (MovePlayer { player: One
                                                , move: Direction Down}) s.pong})
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                pure a
              eval (StopGame a) = do
                s <- get
                case s.loop of
                  (Just i) -> do
                    liftH <<< liftEff $ clearInterval i
                    pure a
                  Nothing -> pure a
                pure a
              eval (StepGame a) = do
                modify (\s -> s {pong = sendCommand Step s.pong})
                pure a

canvasName :: String
canvasName = "Foo"

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

startLoop :: forall eff. Eff (timer :: TIMER | eff) Interval
startLoop = interval 1000 $ do
  pure unit

module Component.Pong where

import Prelude
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Timer (clearInterval, interval, Interval, TIMER)
import Data.Int (ceil)
import Data.Maybe (Maybe(..))
import Graphics.Canvas (CANVAS)
import Halogen (ComponentDSL, ComponentHTML, Component, HalogenEffects, action, lifecycleComponent, liftH, get, modify)
import Pong (PongState, DirY(..), Move(..), Player(..), PongCommand(..), renderPong, sendCommand, initialPongState)

type State = { pong :: PongState, loop :: Maybe Interval}

initial :: State
initial = {pong: initialPongState, loop: Nothing}

data Query a = NewGame a | StopGame a | Move a | StepGame a

type PongEffects eff = (canvas :: CANVAS , timer :: TIMER | eff)

game :: forall g eff. (Functor g, MonadEff (HalogenEffects(PongEffects eff)) g) => Component State Query g
game = lifecycleComponent {render, eval, initializer: Just (action NewGame), finalizer: Just (action StopGame)}
            where
              render :: State -> ComponentHTML Query
              render _ = H.canvas [P.id_ canvasName
                                  , E.onKeyDown (E.input_ Move)
                                  , P.tabIndex 0
                                  , P.height $ P.Pixels $ ceil canvasSize.h
                                  , P.width
                                    $ P.Pixels
                                    $ ceil canvasSize.w ]

              eval :: Query ~> (ComponentDSL State Query g)
              eval (NewGame a) = do
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                int <- (liftH <<< liftEff $ startLoop)
                modify (\x -> x {loop = Just int})
                pure a
              eval (Move a) = do
                modify (\s -> s {pong = sendCommand (MovePlayer { player: One
                                                , move: Direction Down}) s.pong})
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                pure a
              eval (StopGame a) = do
                s <- get
                case s.loop of
                  (Just i) -> do
                    liftH <<< liftEff $ clearInterval i
                    pure a
                  Nothing -> pure a
                pure a

canvasName :: String
canvasName = "Foo"

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

startLoop :: forall eff. Eff (timer :: TIMER | eff) Interval
startLoop = interval 1000 $ do
  pure unit


Actually query SparkLocal component (#1581)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.Component
  ( component
  , module SlamData.FileSystem.Dialog.Mount.Component.Query
  , module MCS
  ) where

import SlamData.Prelude

import Data.Argonaut (jsonParser, decodeJson, (.?))
import Data.Lens (set, (.~), (?~))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery as SQ
import SlamData.FileSystem.Dialog.Mount.Component.ChildSlot as CS
import SlamData.FileSystem.Dialog.Mount.Component.Query (Query(..))
import SlamData.FileSystem.Dialog.Mount.Component.State as MCS
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component as SQL2
import SlamData.FileSystem.Dialog.Mount.Scheme as MS
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component as SparkLocal
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as Api
import SlamData.Render.CSS as RC

import Utils.DOM as DOM

type DSL = H.ParentDSL MCS.State Query CS.ChildQuery CS.ChildSlot Message Slam
type HTML = H.ParentHTML Query CS.ChildQuery CS.ChildSlot Slam

component ∷ H.Component HH.HTML Query MCS.Input Message Slam
component =
  H.parentComponent
    { initialState: MCS.initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ MCS.State → HTML
render state@{ new } =
  modalDialog
    [ modalHeader "Mount"
    , modalBody $
        HH.form
          [ HE.onSubmit $ HE.input PreventDefault
          , HP.class_ RC.dialogMount
          ]
          $ (guard new $> fldName state)
          <> (guard new $> selScheme state)
          <> maybe [] (pure ∘ settings) state.settings
          <> maybe [] (pure ∘ errorMessage) state.message
    , modalFooter
        [ progressSpinner state
        , btnCancel
        , btnMount state
        ]
    ]
  where
  settings ∷ MCS.MountSettings → HTML
  settings ss = case ss of
    MCS.MongoDB initialState →
      HH.slot' CS.cpMongoDB unit (MongoDB.comp initialState) unit (HE.input_ Validate)
    MCS.SQL2 initialState →
      HH.slot' CS.cpSQL unit (SQL2.comp initialState) unit (HE.input_ Validate)
    MCS.Couchbase initialState →
      HH.slot' CS.cpCouchbase unit (Couchbase.comp initialState) unit (HE.input_ Validate)
    MCS.MarkLogic initialState →
      HH.slot' CS.cpMarkLogic unit (MarkLogic.comp initialState) unit (HE.input_ Validate)
    MCS.SparkHDFS initialState →
      HH.slot' CS.cpSpark unit (Spark.comp initialState) unit (HE.input_ Validate)
    MCS.SparkLocal initialState ->
      HH.slot' CS.cpSparkLocal unit (SparkLocal.comp initialState) unit (HE.input_ Validate)

fldName ∷ MCS.State → HTML
fldName state =
  HH.div
    [ HP.classes [B.formGroup, RC.mountName] ]
    [ HH.label_
        [ HH.span_ [ HH.text "Name" ]
        , HH.input
            [ HP.class_ B.formControl
            , HE.onValueInput $ HE.input (ModifyState ∘ set MCS._name)
            , HP.value (state.name)
            ]
        ]
    ]

selScheme ∷ MCS.State → HTML
selScheme state =
  HH.div
    [ HP.class_ B.formGroup ]
    [ HH.label_
        [ HH.span_ [ HH.text "Mount type" ]
        , HH.select
            [ HP.class_ B.formControl
            , HE.onValueChange (HE.input SelectScheme ∘ MS.schemeFromString)
            ]
            $ [ HH.option_ [] ] <> schemeOptions
        ]
    ]
  where
  schemeOptions = map (\s → HH.option_ [ HH.text (MS.schemeToString s) ]) MS.schemes

errorMessage ∷ String → HTML
errorMessage msg =
  HH.div
    [ HP.classes [ B.alert, B.alertDanger ] ]
    [ HH.text msg ]

btnCancel ∷ HTML
btnCancel =
  HH.button
    [ HP.classes [B.btn]
    , HE.onClick (HE.input_ RaiseDismiss)
    ]
    [ HH.text "Cancel" ]

btnMount ∷ MCS.State → HTML
btnMount state@{ new, saving } =
  HH.button
    [ HP.classes [B.btn, B.btnPrimary]
    , HP.enabled (not saving && MCS.canSave state)
    , HE.onClick (HE.input_ NotifySave)
    ]
    [ HH.text text ]
  where
  text = if new then "Mount" else "Save changes"

progressSpinner ∷ MCS.State → HTML
progressSpinner { saving } =
  HH.img [ HP.src "img/spin.gif", HP.class_ (RC.mountProgressSpinner saving) ]

eval ∷ Query ~> DSL
eval (ModifyState f next) = H.modify f *> validateInput $> next
eval (SelectScheme newScheme next) = do
  currentScheme ← map MCS.scheme <$> H.gets _.settings
  when (currentScheme /= newScheme) do
    H.modify (MCS._settings .~ map MCS.initialSettings newScheme)
    validateInput
  pure next
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (NotifySave next) = do
  H.raise MountSave
  pure next
eval (Save k) = do
  { parent, name, new } ← H.get
  H.modify (MCS._saving .~ true)
  newName ←
    if new then Api.getNewName parent name else pure (pure name)
  case newName of
    Left err → do
      handleQError err
      pure $ k Nothing
    Right newName' → do
      result ← querySettings (H.request (SQ.Submit parent newName'))
      mount ← case result of
        Just (Right m) → pure (Just m)
        Just (Left err) → do
          handleQError err
          pure Nothing
        Nothing → pure Nothing
      H.modify (MCS._saving .~ false)
      pure $ k mount
eval (PreventDefault ev next) = H.liftEff (DOM.preventDefault ev) $> next
eval (Validate next) = validateInput $> next

handleQError ∷ Api.QError → DSL Unit
handleQError err =
  case GE.fromQError err of
    Left msg → H.modify (MCS._message ?~ formatError msg)
    Right ge → GE.raiseGlobalError ge

validateInput ∷ DSL Unit
validateInput = do
  state ← H.get
  message ← runExceptT do
    liftMaybe (MCS.validate state)
    liftMaybe ∘ join =<< lift (querySettings (H.request SQ.Validate))
  H.modify (MCS._message .~ either Just (const Nothing) message)
  where
  liftMaybe ∷ Maybe String → ExceptT String DSL Unit
  liftMaybe = maybe (pure unit) throwError

formatError ∷ String → String
formatError err =
  "There was a problem saving the mount: " <> extract err
  where
  extract msg =
    either (const msg) id (jsonParser msg >>= decodeJson >>= (_ .? "error"))

querySettings ∷ forall a. (forall s. SQ.SettingsQuery s a) → DSL (Maybe a)
querySettings q = (map MCS.scheme <$> H.gets _.settings) >>= \s →
  case s of
    Just MS.MongoDB → H.query' CS.cpMongoDB unit q
    Just MS.SQL2 → H.query' CS.cpSQL unit q
    Just MS.Couchbase → H.query' CS.cpCouchbase unit q
    Just MS.MarkLogic → H.query' CS.cpMarkLogic unit q
    Just MS.SparkHDFS → H.query' CS.cpSpark unit q
    Just MS.SparkLocal → H.query' CS.cpSparkLocal unit q
    Nothing → pure Nothing

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.Component
  ( component
  , module SlamData.FileSystem.Dialog.Mount.Component.Query
  , module MCS
  ) where

import SlamData.Prelude

import Data.Argonaut (jsonParser, decodeJson, (.?))
import Data.Lens (set, (.~), (?~))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery as SQ
import SlamData.FileSystem.Dialog.Mount.Component.ChildSlot as CS
import SlamData.FileSystem.Dialog.Mount.Component.Query (Query(..))
import SlamData.FileSystem.Dialog.Mount.Component.State as MCS
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component as SQL2
import SlamData.FileSystem.Dialog.Mount.Scheme as MS
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component as SparkLocal
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as Api
import SlamData.Render.CSS as RC

import Utils.DOM as DOM

type DSL = H.ParentDSL MCS.State Query CS.ChildQuery CS.ChildSlot Message Slam
type HTML = H.ParentHTML Query CS.ChildQuery CS.ChildSlot Slam

component ∷ H.Component HH.HTML Query MCS.Input Message Slam
component =
  H.parentComponent
    { initialState: MCS.initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ MCS.State → HTML
render state@{ new } =
  modalDialog
    [ modalHeader "Mount"
    , modalBody $
        HH.form
          [ HE.onSubmit $ HE.input PreventDefault
          , HP.class_ RC.dialogMount
          ]
          $ (guard new $> fldName state)
          <> (guard new $> selScheme state)
          <> maybe [] (pure ∘ settings) state.settings
          <> maybe [] (pure ∘ errorMessage) state.message
    , modalFooter
        [ progressSpinner state
        , btnCancel
        , btnMount state
        ]
    ]
  where
  settings ∷ MCS.MountSettings → HTML
  settings ss = case ss of
    MCS.MongoDB initialState →
      HH.slot' CS.cpMongoDB unit (MongoDB.comp initialState) unit (HE.input_ Validate)
    MCS.SQL2 initialState →
      HH.slot' CS.cpSQL unit (SQL2.comp initialState) unit (HE.input_ Validate)
    MCS.Couchbase initialState →
      HH.slot' CS.cpCouchbase unit (Couchbase.comp initialState) unit (HE.input_ Validate)
    MCS.MarkLogic initialState →
      HH.slot' CS.cpMarkLogic unit (MarkLogic.comp initialState) unit (HE.input_ Validate)
    MCS.SparkHDFS initialState →
      HH.slot' CS.cpSpark unit (Spark.comp initialState) unit (HE.input_ Validate)
    MCS.SparkLocal initialState ->
      HH.slot' CS.cpSparkLocal unit (SparkLocal.comp initialState) unit (HE.input_ Validate)

fldName ∷ MCS.State → HTML
fldName state =
  HH.div
    [ HP.classes [B.formGroup, RC.mountName] ]
    [ HH.label_
        [ HH.span_ [ HH.text "Name" ]
        , HH.input
            [ HP.class_ B.formControl
            , HE.onValueInput $ HE.input (ModifyState ∘ set MCS._name)
            , HP.value (state.name)
            ]
        ]
    ]

selScheme ∷ MCS.State → HTML
selScheme state =
  HH.div
    [ HP.class_ B.formGroup ]
    [ HH.label_
        [ HH.span_ [ HH.text "Mount type" ]
        , HH.select
            [ HP.class_ B.formControl
            , HE.onValueChange (HE.input SelectScheme ∘ MS.schemeFromString)
            ]
            $ [ HH.option_ [] ] <> schemeOptions
        ]
    ]
  where
  schemeOptions = map (\s → HH.option_ [ HH.text (MS.schemeToString s) ]) MS.schemes

errorMessage ∷ String → HTML
errorMessage msg =
  HH.div
    [ HP.classes [ B.alert, B.alertDanger ] ]
    [ HH.text msg ]

btnCancel ∷ HTML
btnCancel =
  HH.button
    [ HP.classes [B.btn]
    , HE.onClick (HE.input_ RaiseDismiss)
    ]
    [ HH.text "Cancel" ]

btnMount ∷ MCS.State → HTML
btnMount state@{ new, saving } =
  HH.button
    [ HP.classes [B.btn, B.btnPrimary]
    , HP.enabled (not saving && MCS.canSave state)
    , HE.onClick (HE.input_ NotifySave)
    ]
    [ HH.text text ]
  where
  text = if new then "Mount" else "Save changes"

progressSpinner ∷ MCS.State → HTML
progressSpinner { saving } =
  HH.img [ HP.src "img/spin.gif", HP.class_ (RC.mountProgressSpinner saving) ]

eval ∷ Query ~> DSL
eval (ModifyState f next) = H.modify f *> validateInput $> next
eval (SelectScheme newScheme next) = do
  currentScheme ← map MCS.scheme <$> H.gets _.settings
  when (currentScheme /= newScheme) do
    H.modify (MCS._settings .~ map MCS.initialSettings newScheme)
    validateInput
  pure next
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (NotifySave next) = do
  H.raise MountSave
  pure next
eval (Save k) = do
  { parent, name, new } ← H.get
  H.modify (MCS._saving .~ true)
  newName ←
    if new then Api.getNewName parent name else pure (pure name)
  case newName of
    Left err → do
      handleQError err
      pure $ k Nothing
    Right newName' → do
      result ← querySettings (H.request (SQ.Submit parent newName'))
      mount ← case result of
        Just (Right m) → pure (Just m)
        Just (Left err) → do
          handleQError err
          pure Nothing
        Nothing → pure Nothing
      H.modify (MCS._saving .~ false)
      pure $ k mount
eval (PreventDefault ev next) = H.liftEff (DOM.preventDefault ev) $> next
eval (Validate next) = validateInput $> next

handleQError ∷ Api.QError → DSL Unit
handleQError err =
  case GE.fromQError err of
    Left msg → H.modify (MCS._message ?~ formatError msg)
    Right ge → GE.raiseGlobalError ge

validateInput ∷ DSL Unit
validateInput = do
  state ← H.get
  message ← runExceptT do
    liftMaybe (MCS.validate state)
    liftMaybe ∘ join =<< lift (querySettings (H.request SQ.Validate))
  H.modify (MCS._message .~ either Just (const Nothing) message)
  where
  liftMaybe ∷ Maybe String → ExceptT String DSL Unit
  liftMaybe = maybe (pure unit) throwError

formatError ∷ String → String
formatError err =
  "There was a problem saving the mount: " <> extract err
  where
  extract msg =
    either (const msg) id (jsonParser msg >>= decodeJson >>= (_ .? "error"))

querySettings ∷ forall a. (forall s. SQ.SettingsQuery s a) → DSL (Maybe a)
querySettings q = (map MCS.scheme <$> H.gets _.settings) >>= \s →
  case s of
    Just MS.MongoDB → H.query' CS.cpMongoDB unit q
    Just MS.SQL2 → H.query' CS.cpSQL unit q
    Just MS.Couchbase → H.query' CS.cpCouchbase unit q
    Just MS.MarkLogic → H.query' CS.cpMarkLogic unit q
    Just MS.SparkHDFS → H.query' CS.cpSpark unit q
    _ → pure Nothing


Fix formatting (#160)

Fix formatting (#160)

module Data.String.Regex.Flags where

import Prelude

import Control.MonadPlus (guard)
import Data.String (joinWith)

type RegexFlagsRec =
  { global :: Boolean
  , ignoreCase :: Boolean
  , multiline :: Boolean
  , dotAll :: Boolean
  , sticky :: Boolean
  , unicode :: Boolean
  }

-- | Flags that control matching.
data RegexFlags = RegexFlags RegexFlagsRec

-- | All flags set to false.
noFlags :: RegexFlags
noFlags = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll: false
  , sticky: false
  , unicode: false
  }

-- | Only global flag set to true
global :: RegexFlags
global = RegexFlags
  { global: true
  , ignoreCase: false
  , multiline: false
  , dotAll: false
  , sticky: false
  , unicode: false
  }

-- | Only ignoreCase flag set to true
ignoreCase :: RegexFlags
ignoreCase = RegexFlags
  { global: false
  , ignoreCase: true
  , multiline: false
  , dotAll: false
  , sticky: false
  , unicode: false
  }

-- | Only multiline flag set to true
multiline :: RegexFlags
multiline = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: true
  , dotAll: false
  , sticky: false
  , unicode: false
  }

-- | Only sticky flag set to true
sticky :: RegexFlags
sticky = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll: false
  , sticky: true
  , unicode: false
  }

-- | Only unicode flag set to true
unicode :: RegexFlags
unicode = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll: false
  , sticky: false
  , unicode: true
  }

-- | Only dotAll flag set to true
dotAll :: RegexFlags
dotAll = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll: true
  , sticky: false
  , unicode: false
  }

instance semigroupRegexFlags :: Semigroup RegexFlags where
  append (RegexFlags x) (RegexFlags y) = RegexFlags
    { global: x.global || y.global
    , ignoreCase: x.ignoreCase || y.ignoreCase
    , multiline: x.multiline || y.multiline
    , dotAll: x.dotAll || y.dotAll
    , sticky: x.sticky || y.sticky
    , unicode: x.unicode || y.unicode
    }

instance monoidRegexFlags :: Monoid RegexFlags where
  mempty = noFlags

instance eqRegexFlags :: Eq RegexFlags where
  eq (RegexFlags x) (RegexFlags y)
    = x.global == y.global
    && x.ignoreCase == y.ignoreCase
    && x.multiline == y.multiline
    && x.dotAll == y.dotAll
    && x.sticky == y.sticky
    && x.unicode == y.unicode

instance showRegexFlags :: Show RegexFlags where
  show (RegexFlags flags) =
    let
      usedFlags =
        []
        <> (guard flags.global $> "global")
        <> (guard flags.ignoreCase $> "ignoreCase")
        <> (guard flags.multiline $> "multiline")
        <> (guard flags.dotAll $> "dotAll")
        <> (guard flags.sticky $> "sticky")
        <> (guard flags.unicode $> "unicode")
    in
      if usedFlags == []
      then "noFlags"
      else "(" <> joinWith " <> " usedFlags <> ")"

module Data.String.Regex.Flags where

import Prelude

import Control.MonadPlus (guard)
import Data.String (joinWith)

type RegexFlagsRec =
  { global :: Boolean
  , ignoreCase :: Boolean
  , multiline :: Boolean
  , dotAll :: Boolean
  , sticky :: Boolean
  , unicode :: Boolean
  }

-- | Flags that control matching.
data RegexFlags = RegexFlags RegexFlagsRec

-- | All flags set to false.
noFlags :: RegexFlags
noFlags = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll : false
  , sticky: false
  , unicode: false
  }

-- | Only global flag set to true
global :: RegexFlags
global = RegexFlags
  { global: true
  , ignoreCase: false
  , multiline: false
  , dotAll : false
  , sticky: false
  , unicode: false
  }

-- | Only ignoreCase flag set to true
ignoreCase :: RegexFlags
ignoreCase = RegexFlags
  { global: false
  , ignoreCase: true
  , multiline: false
  , dotAll : false
  , sticky: false
  , unicode: false
  }

-- | Only multiline flag set to true
multiline :: RegexFlags
multiline = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: true
  , dotAll : false
  , sticky: false
  , unicode: false
  }

-- | Only sticky flag set to true
sticky :: RegexFlags
sticky = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll : false
  , sticky: true
  , unicode: false
  }

-- | Only unicode flag set to true
unicode :: RegexFlags
unicode = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll : false
  , sticky: false
  , unicode: true
  }

-- | Only dotAll flag set to true
dotAll :: RegexFlags
dotAll = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , dotAll : true
  , sticky: false
  , unicode: false
  }

instance semigroupRegexFlags :: Semigroup RegexFlags where
  append (RegexFlags x) (RegexFlags y) = RegexFlags
    { global: x.global || y.global
    , ignoreCase: x.ignoreCase || y.ignoreCase
    , multiline: x.multiline || y.multiline
    , dotAll: x.dotAll || y.dotAll
    , sticky: x.sticky || y.sticky
    , unicode: x.unicode || y.unicode
    }

instance monoidRegexFlags :: Monoid RegexFlags where
  mempty = noFlags

instance eqRegexFlags :: Eq RegexFlags where
  eq (RegexFlags x) (RegexFlags y)
    = x.global == y.global
    && x.ignoreCase == y.ignoreCase
    && x.multiline == y.multiline
    && x.dotAll == y.dotAll
    && x.sticky == y.sticky
    && x.unicode == y.unicode

instance showRegexFlags :: Show RegexFlags where
  show (RegexFlags flags) =
    let
      usedFlags =
        []
        <> (guard flags.global $> "global")
        <> (guard flags.ignoreCase $> "ignoreCase")
        <> (guard flags.multiline $> "multiline")
        <> (guard flags.dotAll $> "dotAll")
        <> (guard flags.sticky $> "sticky")
        <> (guard flags.unicode $> "unicode")
    in
      if usedFlags == []
      then "noFlags"
      else "(" <> joinWith " <> " usedFlags <> ")"