Fix up regex in lexer references transform

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.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) 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(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | 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

-- | 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")

data Mode = Usage | Descriptions

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

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

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m 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

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

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
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  ]
  <* 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 $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

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

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

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

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

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

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

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

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

_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 <> ">"

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

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

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

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

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

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

  , pure Nothing
  ]

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

  pure $ SOpt x xs arg

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

  name' <- 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, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

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

  , pure Nothing
  ]

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

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

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

flag :: P.Parser String Char
flag = lowerAlphaNum

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

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

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

anyToken :: 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 { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

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

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.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) 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(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | 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

-- | 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*\\]"
        (Regex.parseFlags "gmi")

data Mode = Usage | Descriptions

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

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

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m 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

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

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
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  ]
  <* 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 $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

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

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

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

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

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

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

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

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

_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 <> ">"

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

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

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

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

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

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

  , pure Nothing
  ]

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

  pure $ SOpt x xs arg

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

  name' <- 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, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

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

  , pure Nothing
  ]

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

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

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

flag :: P.Parser String Char
flag = lowerAlphaNum

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

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

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

anyToken :: 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 { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

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


Reduce duplication

Reduce duplication

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Functor.Mu (Mu)
import Data.Json.Extended as EJ
import Data.Lens ((^?), (?~), (.~))
import Data.List as L
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Matryoshka as M
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        case SM.lookup var varMap of
          Just (Right v) → do
            -- If the var is an ident, use `SELECT * FROM :ident`
            -- If the var is an literal, use `SELECT :literal AS literal`
            -- If the var is any other expr, use it directly
            case unwrapParens (unwrap v) of
              Sql.Ident _ →
                Sql.buildSelect
                  $ all
                  ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
              Sql.Literal _ →
                selectVarAsVar var v
              Sql.SetLiteral _ →
                selectVarAsVar var v
              _ →
                unwrap v
          _ →
            -- This case should be impossible - if we selected a var in the
            -- card, the var should exist during eval
            Sql.set L.Nil
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res
    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where

  selectVarAsVar ∷ String → VM.VarMapValue → Sql.Sql
  selectVarAsVar var v =
    Sql.buildSelect
      $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)

  unwrapParens ∷ Sql.Sql → Sql.SqlF EJ.EJsonF (Mu (Sql.SqlF EJ.EJsonF))
  unwrapParens expr =
    case M.project expr of
      Sql.Parens expr' → unwrapParens expr'
      expr' → expr'

  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Functor.Mu (Mu)
import Data.Json.Extended as EJ
import Data.Lens ((^?), (?~), (.~))
import Data.List as L
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Matryoshka as M
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        case SM.lookup var varMap of
          Just (Right v) → do
            -- If the var is an ident, use `SELECT * FROM :ident`
            -- If the var is an literal, use `SELECT :literal AS varName`
            -- If the var is any other expr, use it directly
            case unwrapParens (unwrap v) of
              Sql.Ident _ →
                Sql.buildSelect
                  $ all
                  ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
              Sql.Literal _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              Sql.SetLiteral _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              _ →
                unwrap v
          _ →
            -- This case should be impossible - if we selected a var in the
            -- card, the var should exist during eval
            Sql.set L.Nil
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res
    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where
  unwrapParens ∷ Sql.Sql → Sql.SqlF EJ.EJsonF (Mu (Sql.SqlF EJ.EJsonF))
  unwrapParens expr =
    case M.project expr of
      Sql.Parens expr' → unwrapParens expr'
      expr' → expr'

  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)


Add some more sophisticated cases to row constructors test suite

module Main where

type Foo = (x :: Number | (y :: Number | (z :: Number)))
type Bar = (x :: Number, y :: Number, z :: Number)
type Baz = { w :: Number | Bar }

foo :: { | Foo }
foo = { x: 0, y: 0, z: 0 }

bar :: { | Bar }
bar = { x: 0, y: 0, z: 0 }

id' :: Object Foo -> Object Bar
id' = id

foo' :: { | Foo }
foo' = id' foo

bar' :: { | Bar }
bar' = id' bar

baz :: Baz
baz = { x: 0, y: 0, z: 0, w: 0 }

type Quux r = (q :: Number | r)
type Norf r = (q' :: Number | Quux r)

quux :: { f :: { | Foo } | Quux Bar }
quux = { f: foo', x: 0, y: 0, z: 0, q: 0 }

quux' :: { | Norf Bar }
quux' = { x: 0, y: 0, z: 0, q: 0, q': 0 }

wildcard :: { w :: Number | _ } -> Baz
wildcard { w: w } = { x: w, y: w, z: w, w: w }

wildcard' :: { | Quux _ } -> Number
wildcard' { q: q } = q

main = Debug.Trace.trace "Done"

module Main where

type Foo = (x :: Number | (y :: Number | (z :: Number)))
type Bar = (x :: Number, y :: Number, z :: Number)
type Baz = { w :: Number | Bar }

foo :: { | Foo }
foo = { x: 0, y: 0, z: 0 }

bar :: { | Bar }
bar = { x: 0, y: 0, z: 0 }

id' :: Object Foo -> Object Bar
id' = id

foo' :: { | Foo }
foo' = id' foo

bar' :: { | Bar }
bar' = id' bar

baz :: Baz
baz = { x: 0, y: 0, z: 0, w: 0 }

main = Debug.Trace.trace "Done"


added more powerful variants of foldGen (foldGen') and sample' (runGen)

module Test.QuickCheck.LCG
  ( GenT(..)
  , Gen(..)
  , GenState(..)
  , GenOut(..)
  , Size()
  , Seed()
  , allInArray
  , allInRange
  , arrayOf
  , arrayOf1
  , choose
  , chooseInt
  , collectAll
  , dropGen
  , elements
  , extend
  , foldGen
  , foldGen'
  , frequency
  , infinite
  , oneOf
  , perturbGen
  , repeatable
  , resize
  , runGen
  , sample
  , sample'
  , showSample
  , showSample'
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , takeGen
  , unfoldGen
  , uniform
  , variant
  , vectorOf
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Tuple
import Data.Lazy
import Data.Profunctor
import Data.Monoid
import Data.Monoid.Sum
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Foldable
import Data.Traversable
import qualified Data.Array as A
import Control.Monad.Free
import Control.Monad.Trampoline
import Control.Arrow
import Control.Monad
import Control.Bind
import qualified Math as M
import qualified Data.Machine.Mealy as Mealy

type Size = Number
type Seed  = Number

data GenState = GenState { seed :: Seed, size :: Size }

unGenState :: GenState -> { seed :: Seed, size :: Size }
unGenState (GenState s) = s

stateM :: ({ seed :: Seed, size :: Size } -> { seed :: Seed, size :: Size }) -> GenState -> GenState
stateM f = GenState <<< f <<< unGenState

data GenOut a = GenOut { state :: GenState, value :: a }

unGenOut :: forall a. GenOut a -> { state :: GenState, value :: a }
unGenOut (GenOut v) = v

data GenT f a = GenT (Mealy.MealyT f GenState (GenOut a))

type Gen a = GenT Trampoline a

unGen :: forall f a. GenT f a -> Mealy.MealyT f GenState (GenOut a)
unGen (GenT m) = m

lcgM :: Seed
lcgM = 1103515245

lcgC :: Seed
lcgC = 12345

lcgN :: Seed
lcgN = 1 `shl` 30

lcgNext :: Seed -> Seed
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: forall f. (Monad f) => GenT f Seed
lcgStep = GenT $ arr $ \s -> GenOut { state: updateSeedState s, value: (unGenState s).seed }

uniform :: forall f. (Monad f) => GenT f Seed
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

stepGen :: forall f a. (Monad f) => GenState -> GenT f a -> f (Maybe (GenOut (Tuple a (GenT f a))))
stepGen st (GenT m) =   h <$> Mealy.stepMealy st m
                        where h Mealy.Halt        = Nothing
                              h (Mealy.Emit a m)  = Just $ flip Tuple (GenT m) <$> a

evalGen :: forall f a. (Monad f) => GenT f a -> GenState -> f (Maybe a)
evalGen g st = h <$> stepGen st g
                where h Nothing                               = Nothing
                      h (Just (GenOut { value = Tuple a _ })) = Just a

pureGen :: forall f a. (Monad f) => (GenState -> GenOut a) -> GenT f a
pureGen f = GenT $ arr f

repeatable' :: forall f a b. (Monad f) => (a -> GenT f b) -> GenT f (a -> f b)
repeatable' f = GenT $
  Mealy.pureMealy $ \s -> Mealy.Emit (GenOut { state: s, value: \a -> fromJust <$> evalGen (f a) s }) Mealy.halt

-- | Creates a function generator that will always generate the same output
-- | for the same input.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = g <$> repeatable' f
               where g f' = \a -> runTrampoline $ f' a

-- | Creates a generator that depends on access to the generator state.
stateful :: forall f a. (Monad f) => (GenState -> GenT f a) -> GenT f a
stateful f = GenT $ do s <- Mealy.take 1 id
                       unGen (f s)

-- | Fixes a generator on a certain variant, given by the specified seed.
variant :: forall f a. (Monad f) => Seed -> GenT f a -> GenT f a
variant n g = GenT $ lmap (stateM (\s -> s { seed = n })) (unGen g)

-- | Creates a generator that depends on the size parameter.
sized :: forall f a. (Monad f) => (Size -> GenT f a) -> GenT f a
sized f = stateful $ \s -> f (unGenState s).size

-- | Resizes the generator so the size parameter passed into the generator
-- | will be equal to the specified size.
resize :: forall f a. (Monad f) => Size -> GenT f a -> GenT f a
resize sz g = GenT $ lmap (stateM (\s -> s { size = sz })) (unGen g)

-- | Creates a generator that generates real numbers between the specified
-- | inclusive range.
choose :: forall f. (Monad f) => Number -> Number -> GenT f Number
choose a b = (*) (max - min) >>> (+) min <$> uniform
  where min = M.min a b
        max = M.max a b

-- | Creates a generator that generates integers between the specified
-- | inclusive range.
chooseInt :: forall f. (Monad f) => Number -> Number -> GenT f Number
chooseInt a b = let min = M.ceil  (M.min a b)
                    max = M.floor (M.max a b)
                in  (M.round <<< (+) (min - 0.5) <<< (*) (max - min + 1)) <$> uniform

-- | Creates a generator that chooses another generator from the specified list
-- | at random, and then generates a value with that generator.
oneOf :: forall f a. (Monad f) => GenT f a -> [GenT f a] -> GenT f a
oneOf x xs = do n <- chooseInt 0 (A.length xs)
                if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

-- | Generates elements by the specified frequencies (which will be normalized).
frequency :: forall f a. (Monad f) => Tuple Number (GenT f a) -> [Tuple Number (GenT f a)] -> GenT f a
frequency x xs =
  let xxs   = x : xs
      total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
      pick n d [] = d
      pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs

  in do n <- chooseInt 1 total
        pick n (snd x) xxs

-- | Creates a generator of elements ranging from 0 to the maximum size.
arrayOf :: forall f a. (Monad f) => GenT f a -> GenT f [a]
arrayOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

-- | Creates a generator of elements ranging from 1 to the maximum size.
arrayOf1 :: forall f a. (Monad f) => GenT f a -> GenT f (Tuple a [a])
arrayOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

-- | Creates a generator that generates arrays of some specified size.
vectorOf :: forall f a. (Monad f) => Number -> GenT f a -> GenT f [a]
vectorOf n g = unfoldGen f [] (extend n g)
  where f b a = let b' = b <> [a]
                in  if A.length b' >= n then Tuple [] (Just b') else Tuple b' Nothing

-- | Creates a generator that chooses an element from among a set of elements.
elements :: forall f a. (Monad f) => a -> [a] -> GenT f a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
perturbGen n (GenT m) = GenT $ lmap (stateM (\s -> s { seed = perturbNum n s.seed })) m

perturbNum :: Number -> Seed -> Seed
perturbNum n = (+) $ lcgNext (float32ToInt32 n)

updateSeedState :: GenState -> GenState
updateSeedState (GenState s) = GenState { seed: lcgNext s.seed, size: s.size }

updateSeedGen :: forall f a. (Monad f) => GenT f a -> GenT f a
updateSeedGen (GenT m) = GenT $ lmap updateSeedState m

liftMealy :: forall f a. (Monad f) => (Mealy.MealyT f GenState (GenOut a) -> Mealy.MealyT f GenState (GenOut a)) -> (GenT f a -> GenT f a)
liftMealy f = \g -> GenT $ f (unGen g)

-- | Takes the first number of values from the generator. Will turn an infinite
-- | generator into a finite generator.
takeGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
takeGen n = liftMealy $ Mealy.take n

-- | Drops a certain number of values from the generator. May produce
-- | an empty generator if called on a finite generator.
dropGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
dropGen n = liftMealy $ Mealy.drop n

-- | Extends a generator to produce *at least* the specified number of values.
-- | Will not turn a finite generator into an infinite one.
extend :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
extend n (GenT m) = GenT $ loop 0 m
  where m0 = m
        loop i m = Mealy.mealy \st ->
          let f Mealy.Halt       = if i >= n then pure Mealy.Halt else Mealy.stepMealy st (loop i m0)
              f (Mealy.Emit s m) = pure $ Mealy.Emit s (loop (i + 1) m)

          in  Mealy.stepMealy st m >>= f

-- | Ensures that a given generator can produce an infinite number of values,
-- | assuming it can produce at least one.
infinite :: forall f a. (Monad f) => GenT f a -> GenT f a
infinite = liftMealy $ Mealy.loop

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may terminate the fold. Returns not just the value
-- | created through folding, but also the successor generator.
foldGen' :: forall f a b. (Monad f) => (b -> a -> Maybe b) -> b -> GenState -> GenT f a -> f (Tuple b (GenT f a))
foldGen' f b s (GenT m) = loop s m b where
  loop st m b = Mealy.stepMealy st m >>= g
    where g Mealy.Halt                                        = pure $ Tuple b (GenT Mealy.halt)
          g (Mealy.Emit (GenOut { value = a, state = st }) m) = let b' = f b a in maybe (pure $ Tuple b (GenT m)) (loop st m) b'

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may terminate the fold.
foldGen :: forall f a b. (Monad f) => (b -> a -> Maybe b) -> b -> GenState -> GenT f a -> f b
foldGen f b s g = fst <$> foldGen' f b s g

unfoldGen :: forall f a b c. (Monad f) => (b -> a -> Tuple b (Maybe c)) -> b -> GenT f a -> GenT f c
unfoldGen f b (GenT m) = GenT $ loop m b where
  loop m b = Mealy.mealy $ \st -> Mealy.stepMealy st m >>= g
    where g Mealy.Halt                                        = pure Mealy.Halt
          g (Mealy.Emit (GenOut { value = a, state = st }) m) = case f b a of
                                                                  Tuple b Nothing  -> Mealy.stepMealy st (loop m b)
                                                                  Tuple b (Just c) ->
                                                                    let c' = GenOut { value: c, state: st }
                                                                    in  pure $ Mealy.Emit c' (loop m b)

-- FIXME: workaround type inference unification bug
ifThenElse p a b = if p then a else b

-- | Filters a generator to produce only values satisfying the specified
-- | predicate.
suchThat :: forall f a. (Monad f) => GenT f a -> (a -> Boolean) -> GenT f a
suchThat g p = unfoldGen f unit g where
  f _ a = Tuple unit $ ifThenElse (p a) (Just a) Nothing

-- | Filters a generator to produce only values satisfying the specified
-- | predicate, but gives up and produces Nothing after the specified number
-- | of attempts.
suchThatMaybe :: forall f a. (Monad f) => Number -> GenT f a -> (a -> Boolean) -> GenT f (Maybe a)
suchThatMaybe n g p = unfoldGen f 0 g where
  f i a = ifThenElse (p a) (Tuple 0 (Just $ Just a)) (ifThenElse (i >= n) (Tuple 0 (Just $ Nothing)) (Tuple (i + 1) Nothing))

-- | A deterministic generator that produces integers from the specified
-- | inclusive range, in sequence.
allInRange :: forall f a. (Monad f) => Number -> Number -> GenT f Number
allInRange min max = GenT $ go min where
  go cur = Mealy.pureMealy $ \s ->
    ifThenElse (cur > max) Mealy.Halt (Mealy.Emit (GenOut { state: s, value: cur }) (go (cur + 1)))

-- | A deterministic generator that produces values from the specified array,
-- | in sequence.
allInArray :: forall f a. (Monad f) => [a] -> GenT f a
allInArray a = GenT $ go 0 where
  go i = Mealy.pureMealy $ \s ->
    maybe Mealy.Halt (\a -> Mealy.Emit (GenOut { state: s, value: a }) (go (i + 1))) (a A.!! i)

-- | Drains a finite generator of all values. Or blows up if you called it on
-- | an infinite generator.
collectAll :: forall f a. (Monad f) => GenState -> GenT f a -> f [a]
collectAll = foldGen f []
  where f v a = Just $ v <> [a]

-- | Samples a generator, producing the specified number of values.
sample' :: forall f a. (Monad f) => Number -> GenState -> GenT f a -> f [a]
sample' n st g = fst <$> runGen n st g

-- | Samples a generator, producing the specified number of values. Uses
-- | default settings for the initial generator state.
sample :: forall f a. (Monad f) => Number -> GenT f a -> f [a]
sample n = sample' n (GenState { size: 10, seed: 0 })

-- | Shows a sample of values generated from the specified generator.
showSample' :: forall r a. (Show a) => Number -> Gen a -> Eff (trace :: Trace | r) Unit
showSample' n g = print $ runTrampoline $ sample n g

-- | Shows a sample of values generated from the specified generator.
showSample :: forall r a. (Show a) => Gen a -> Eff (trace :: Trace | r) Unit
showSample = showSample' 10

runGen :: forall f a. (Monad f) => Number -> GenState -> GenT f a -> f (Tuple [a] (GenT f a))
runGen n st g = foldGen' f [] st (extend n g)
  where f v a = ifThenElse (A.length v < n) (Just $ v <> [a]) Nothing

instance semigroupGenState :: Semigroup GenState where
  (<>) (GenState a) (GenState b) = GenState { seed: perturbNum a.seed b.seed, size: b.size }

instance monoidGenState :: Monoid GenState where
  mempty = GenState { seed: 0, size: 10 }

instance semigroupGenOut :: (Semigroup a) => Semigroup (GenOut a) where
  (<>) (GenOut a) (GenOut b) = GenOut { state: a.state <> b.state, value: a.value <> b.value }

instance monoidGenOut :: (Monoid a) => Monoid (GenOut a) where
  mempty = GenOut { state: mempty, value: mempty }

instance functorGenOut :: Functor GenOut where
  (<$>) f (GenOut m) = GenOut { state: m.state, value: f m.value }

instance applyGenOut :: Apply GenOut where
  (<*>) (GenOut f) (GenOut x) = GenOut { state: x.state, value: f.value x.value }

-- GenT instances
instance functorGenT :: (Monad f) => Functor (GenT f) where
  (<$>) f (GenT m) = GenT $ (<$>) f <$> m

instance applyGenT :: (Monad f) => Apply (GenT f) where
  (<*>) f x = GenT $ do f <- unGen f
                        x <- unGen $ updateSeedGen x
                        return $ f <*> x

instance applicativeGenT :: (Monad f) => Applicative (GenT f) where
  pure t = GenT $ arr (\s -> GenOut { state: updateSeedState s, value: t })

instance semigroupGenT :: (Monad f) => Semigroup (GenT f a) where
  (<>) (GenT a) (GenT b) = GenT (a <> b)

instance monoidGenT :: (Monad f) => Monoid (GenT f a) where
  mempty = GenT mempty

instance bindGenT :: (Monad f) => Bind (GenT f) where
  (>>=) (GenT m) f = GenT $ do a <- m
                               unGen $ updateSeedGen (f (unGenOut a).value)

instance monadGenT :: (Monad f) => Monad (GenT f)

module Test.QuickCheck.LCG
  ( GenT(..)
  , Gen(..)
  , GenState(..)
  , GenOut(..)
  , Size()
  , Seed()
  , allInArray
  , allInRange
  , arrayOf
  , arrayOf1
  , choose
  , chooseInt
  , collectAll
  , dropGen
  , elements
  , extend
  , foldGen
  , frequency
  , infinite
  , oneOf
  , perturbGen
  , repeatable
  , resize
  , sample
  , sample'
  , showSample
  , showSample'
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , takeGen
  , unfoldGen
  , uniform
  , variant
  , vectorOf
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Tuple
import Data.Lazy
import Data.Profunctor
import Data.Monoid
import Data.Monoid.Sum
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Foldable
import Data.Traversable
import qualified Data.Array as A
import Control.Monad.Free
import Control.Monad.Trampoline
import Control.Arrow
import Control.Monad
import Control.Bind
import qualified Math as M
import qualified Data.Machine.Mealy as Mealy

type Size = Number
type Seed  = Number

data GenState = GenState { seed :: Seed, size :: Size }

unGenState :: GenState -> { seed :: Seed, size :: Size }
unGenState (GenState s) = s

stateM :: ({ seed :: Seed, size :: Size } -> { seed :: Seed, size :: Size }) -> GenState -> GenState
stateM f = GenState <<< f <<< unGenState

data GenOut a = GenOut { state :: GenState, value :: a }

unGenOut :: forall a. GenOut a -> { state :: GenState, value :: a }
unGenOut (GenOut v) = v

data GenT f a = GenT (Mealy.MealyT f GenState (GenOut a))

type Gen a = GenT Trampoline a

unGen :: forall f a. GenT f a -> Mealy.MealyT f GenState (GenOut a)
unGen (GenT m) = m

lcgM :: Seed
lcgM = 1103515245

lcgC :: Seed
lcgC = 12345

lcgN :: Seed
lcgN = 1 `shl` 30

lcgNext :: Seed -> Seed
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: forall f. (Monad f) => GenT f Seed
lcgStep = GenT $ arr $ \s -> GenOut { state: updateSeedState s, value: (unGenState s).seed }

uniform :: forall f. (Monad f) => GenT f Seed
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

stepGen :: forall f a. (Monad f) => GenState -> GenT f a -> f (Maybe (GenOut (Tuple a (GenT f a))))
stepGen st (GenT m) =   h <$> Mealy.stepMealy st m
                        where h Mealy.Halt        = Nothing
                              h (Mealy.Emit a m)  = Just $ flip Tuple (GenT m) <$> a

evalGen :: forall f a. (Monad f) => GenT f a -> GenState -> f (Maybe a)
evalGen g st = h <$> stepGen st g
                where h Nothing                               = Nothing
                      h (Just (GenOut { value = Tuple a _ })) = Just a

pureGen :: forall f a. (Monad f) => (GenState -> GenOut a) -> GenT f a
pureGen f = GenT $ arr f

repeatable' :: forall f a b. (Monad f) => (a -> GenT f b) -> GenT f (a -> f b)
repeatable' f = GenT $
  Mealy.pureMealy $ \s -> Mealy.Emit (GenOut { state: s, value: \a -> fromJust <$> evalGen (f a) s }) Mealy.halt

-- | Creates a function generator that will always generate the same output
-- | for the same input.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = g <$> repeatable' f
               where g f' = \a -> runTrampoline $ f' a

-- | Creates a generator that depends on access to the generator state.
stateful :: forall f a. (Monad f) => (GenState -> GenT f a) -> GenT f a
stateful f = GenT $ do s <- Mealy.take 1 id
                       unGen (f s)

-- | Fixes a generator on a certain variant, given by the specified seed.
variant :: forall f a. (Monad f) => Seed -> GenT f a -> GenT f a
variant n g = GenT $ lmap (stateM (\s -> s { seed = n })) (unGen g)

-- | Creates a generator that depends on the size parameter.
sized :: forall f a. (Monad f) => (Size -> GenT f a) -> GenT f a
sized f = stateful $ \s -> f (unGenState s).size

-- | Resizes the generator so the size parameter passed into the generator
-- | will be equal to the specified size.
resize :: forall f a. (Monad f) => Size -> GenT f a -> GenT f a
resize sz g = GenT $ lmap (stateM (\s -> s { size = sz })) (unGen g)

-- | Creates a generator that generates real numbers between the specified
-- | inclusive range.
choose :: forall f. (Monad f) => Number -> Number -> GenT f Number
choose a b = (*) (max - min) >>> (+) min <$> uniform
  where min = M.min a b
        max = M.max a b

-- | Creates a generator that generates integers between the specified
-- | inclusive range.
chooseInt :: forall f. (Monad f) => Number -> Number -> GenT f Number
chooseInt a b = let min = M.ceil  (M.min a b)
                    max = M.floor (M.max a b)
                in  (M.round <<< (+) (min - 0.5) <<< (*) (max - min + 1)) <$> uniform

-- | Creates a generator that chooses another generator from the specified list
-- | at random, and then generates a value with that generator.
oneOf :: forall f a. (Monad f) => GenT f a -> [GenT f a] -> GenT f a
oneOf x xs = do n <- chooseInt 0 (A.length xs)
                if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

-- | Generates elements by the specified frequencies (which will be normalized).
frequency :: forall f a. (Monad f) => Tuple Number (GenT f a) -> [Tuple Number (GenT f a)] -> GenT f a
frequency x xs =
  let xxs   = x : xs
      total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
      pick n d [] = d
      pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs

  in do n <- chooseInt 1 total
        pick n (snd x) xxs

-- | Creates a generator of elements ranging from 0 to the maximum size.
arrayOf :: forall f a. (Monad f) => GenT f a -> GenT f [a]
arrayOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

-- | Creates a generator of elements ranging from 1 to the maximum size.
arrayOf1 :: forall f a. (Monad f) => GenT f a -> GenT f (Tuple a [a])
arrayOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

-- | Creates a generator that generates arrays of some specified size.
vectorOf :: forall f a. (Monad f) => Number -> GenT f a -> GenT f [a]
vectorOf n g = unfoldGen f [] (extend n g)
  where f b a = let b' = b <> [a]
                in  if A.length b' >= n then Tuple [] (Just b') else Tuple b' Nothing

-- | Creates a generator that chooses an element from among a set of elements.
elements :: forall f a. (Monad f) => a -> [a] -> GenT f a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
perturbGen n (GenT m) = GenT $ lmap (stateM (\s -> s { seed = perturbNum n s.seed })) m

perturbNum :: Number -> Seed -> Seed
perturbNum n = (+) $ lcgNext (float32ToInt32 n)

updateSeedState :: GenState -> GenState
updateSeedState (GenState s) = GenState { seed: lcgNext s.seed, size: s.size }

updateSeedGen :: forall f a. (Monad f) => GenT f a -> GenT f a
updateSeedGen (GenT m) = GenT $ lmap updateSeedState m

liftMealy :: forall f a. (Monad f) => (Mealy.MealyT f GenState (GenOut a) -> Mealy.MealyT f GenState (GenOut a)) -> (GenT f a -> GenT f a)
liftMealy f = \g -> GenT $ f (unGen g)

-- | Takes the first number of values from the generator. Will turn an infinite
-- | generator into a finite generator.
takeGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
takeGen n = liftMealy $ Mealy.take n

-- | Drops a certain number of values from the generator. May produce
-- | an empty generator if called on a finite generator.
dropGen :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
dropGen n = liftMealy $ Mealy.drop n

-- | Extends a generator to produce *at least* the specified number of values.
-- | Will not turn a finite generator into an infinite one.
extend :: forall f a. (Monad f) => Number -> GenT f a -> GenT f a
extend n (GenT m) = GenT $ loop 0 m
  where m0 = m
        loop i m = Mealy.mealy \st ->
          let f Mealy.Halt       = if i >= n then pure Mealy.Halt else Mealy.stepMealy st (loop i m0)
              f (Mealy.Emit s m) = pure $ Mealy.Emit s (loop (i + 1) m)

          in  Mealy.stepMealy st m >>= f

-- | Ensures that a given generator can produce an infinite number of values,
-- | assuming it can produce at least one.
infinite :: forall f a. (Monad f) => GenT f a -> GenT f a
infinite = liftMealy $ Mealy.loop

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may terminate the fold.
foldGen :: forall f a b. (Monad f) => (b -> a -> Maybe b) -> b -> GenState -> GenT f a -> f b
foldGen f b s (GenT m) = loop s m b where
  loop st m b = Mealy.stepMealy st m >>= g
    where g Mealy.Halt                                        = pure b
          g (Mealy.Emit (GenOut { value = a, state = st }) m) = let b' = f b a in maybe (pure b) (loop st m) b'

unfoldGen :: forall f a b c. (Monad f) => (b -> a -> Tuple b (Maybe c)) -> b -> GenT f a -> GenT f c
unfoldGen f b (GenT m) = GenT $ loop m b where
  loop m b = Mealy.mealy $ \st -> Mealy.stepMealy st m >>= g
    where g Mealy.Halt                                        = pure Mealy.Halt
          g (Mealy.Emit (GenOut { value = a, state = st }) m) = case f b a of
                                                                  Tuple b Nothing  -> Mealy.stepMealy st (loop m b)
                                                                  Tuple b (Just c) ->
                                                                    let c' = GenOut { value: c, state: st }
                                                                    in  pure $ Mealy.Emit c' (loop m b)

-- FIXME: workaround type inference unification bug
ifThenElse p a b = if p then a else b

-- | Filters a generator to produce only values satisfying the specified
-- | predicate.
suchThat :: forall f a. (Monad f) => GenT f a -> (a -> Boolean) -> GenT f a
suchThat g p = unfoldGen f unit g where
  f _ a = Tuple unit $ ifThenElse (p a) (Just a) Nothing

-- | Filters a generator to produce only values satisfying the specified
-- | predicate, but gives up and produces Nothing after the specified number
-- | of attempts.
suchThatMaybe :: forall f a. (Monad f) => Number -> GenT f a -> (a -> Boolean) -> GenT f (Maybe a)
suchThatMaybe n g p = unfoldGen f 0 g where
  f i a = ifThenElse (p a) (Tuple 0 (Just $ Just a)) (ifThenElse (i >= n) (Tuple 0 (Just $ Nothing)) (Tuple (i + 1) Nothing))

-- | A deterministic generator that produces integers from the specified
-- | inclusive range, in sequence.
allInRange :: forall f a. (Monad f) => Number -> Number -> GenT f Number
allInRange min max = GenT $ go min where
  go cur = Mealy.pureMealy $ \s ->
    ifThenElse (cur > max) Mealy.Halt (Mealy.Emit (GenOut { state: s, value: cur }) (go (cur + 1)))

-- | A deterministic generator that produces values from the specified array,
-- | in sequence.
allInArray :: forall f a. (Monad f) => [a] -> GenT f a
allInArray a = GenT $ go 0 where
  go i = Mealy.pureMealy $ \s ->
    maybe Mealy.Halt (\a -> Mealy.Emit (GenOut { state: s, value: a }) (go (i + 1))) (a A.!! i)

-- | Drains a finite generator of all values. Or blows up if you called it on
-- | an infinite generator.
collectAll :: forall f a. (Monad f) => GenState -> GenT f a -> f [a]
collectAll = foldGen f []
  where f v a = Just $ v <> [a]

-- | Samples a generator, producing the specified number of values.
sample' :: forall f a. (Monad f) => Number -> GenState -> GenT f a -> f [a]
sample' n st g = foldGen f [] st (extend n g)
  where f v a = ifThenElse (A.length v < n) (Just $ v <> [a]) Nothing

-- | Samples a generator, producing the specified number of values. Uses
-- | default settings for the initial generator state.
sample :: forall f a. (Monad f) => Number -> GenT f a -> f [a]
sample n = sample' n (GenState { size: 10, seed: 0 })

-- | Shows a sample of values generated from the specified generator.
showSample' :: forall r a. (Show a) => Number -> Gen a -> Eff (trace :: Trace | r) Unit
showSample' n g = print $ runTrampoline $ sample n g

-- | Shows a sample of values generated from the specified generator.
showSample :: forall r a. (Show a) => Gen a -> Eff (trace :: Trace | r) Unit
showSample = showSample' 10

instance semigroupGenState :: Semigroup GenState where
  (<>) (GenState a) (GenState b) = GenState { seed: perturbNum a.seed b.seed, size: b.size }

instance monoidGenState :: Monoid GenState where
  mempty = GenState { seed: 0, size: 10 }

instance semigroupGenOut :: (Semigroup a) => Semigroup (GenOut a) where
  (<>) (GenOut a) (GenOut b) = GenOut { state: a.state <> b.state, value: a.value <> b.value }

instance monoidGenOut :: (Monoid a) => Monoid (GenOut a) where
  mempty = GenOut { state: mempty, value: mempty }

instance functorGenOut :: Functor GenOut where
  (<$>) f (GenOut m) = GenOut { state: m.state, value: f m.value }

instance applyGenOut :: Apply GenOut where
  (<*>) (GenOut f) (GenOut x) = GenOut { state: x.state, value: f.value x.value }

-- GenT instances
instance functorGenT :: (Monad f) => Functor (GenT f) where
  (<$>) f (GenT m) = GenT $ (<$>) f <$> m

instance applyGenT :: (Monad f) => Apply (GenT f) where
  (<*>) f x = GenT $ do f <- unGen f
                        x <- unGen $ updateSeedGen x
                        return $ f <*> x

instance applicativeGenT :: (Monad f) => Applicative (GenT f) where
  pure t = GenT $ arr (\s -> GenOut { state: updateSeedState s, value: t })

instance semigroupGenT :: (Monad f) => Semigroup (GenT f a) where
  (<>) (GenT a) (GenT b) = GenT (a <> b)

instance monoidGenT :: (Monad f) => Monoid (GenT f a) where
  mempty = GenT mempty

instance bindGenT :: (Monad f) => Bind (GenT f) where
  (>>=) (GenT m) f = GenT $ do a <- m
                               unGen $ updateSeedGen (f (unGenOut a).value)

instance monadGenT :: (Monad f) => Monad (GenT f)


Fix shadowed name warnings

Fix shadowed name warnings

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures

  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.Either as E
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V

import Halogen as H
import Halogen.HTML.Core as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

import Unsafe.Coerce (unsafeCoerce)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ g v
  . (SD.Value v)
  ⇒ SDQ.SlamDownQuery v
  ~> H.ComponentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) g
evalSlamDownQuery e =
  case e of
    SDQ.TextBoxChanged key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      pure next

    SDQ.RadioButtonChanged key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      pure next

    SDQ.DropDownChanged key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      pure next

    SDQ.CheckBoxChanged key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        let
          desc = SDS.formDescFromDocument document
          keysToPrune = L.filter (\newKey → not (newKey `SM.member` desc)) (L.fromFoldable (SM.keys values))
          prunedValues = F.foldr SM.delete values keysToPrune
        in
          SDS.SlamDownState
            { document
            , formState: prunedValues
            }
      pure next

    SDQ.SetDocument doc next → do
      H.modify $ SDS.replaceDocument doc
      pure next

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer p v a = a → Fresh.Fresh (H.HTML p (SDQ.SlamDownQuery v))

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → H.ComponentHTML (SDQ.SlamDownQuery v)
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        <<< Fresh.runFresh config.formName
        <<< traverse renderBlock
          $ A.fromFoldable bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ ∀ p a. Int → Array (H.HTML p a) → H.HTML p a
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ ∀ p a. SD.ListType → Array (H.HTML p a) → H.HTML p a
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ ∀ p. FreshRenderer p v (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label req def → do
          ident ← Fresh.fresh
          let
            unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
            quote = SD.transFormField (unwrap >>> SD.Literal)
            field =
              unquote <<< ensureValidField <<< M.maybe def quote $
                SM.lookup label state.formState <|> SM.lookup label defaultFormState
          el ←
            case field of
              M.Nothing → pure $ HH.text "Unsupported form element"
              M.Just fv → renderFormElement config state ident label fv

          let
            requiredLabel = if req then "*" else ""
            requiresId =
              case field of
                M.Just (SD.CheckBoxes _ _) → false
                M.Just (SD.RadioButtons _ _) → false
                _ → true

          pure $ HH.span
            [ HP.class_ (HH.className "slamdown-field") ]
            [ HH.label
              (if requiresId then [ HP.for ident ] else [])
              [ HH.text (label <> requiredLabel) ]
            , el
            ]

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ ∀ p. FreshRenderer p v (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> traverse renderBlock (A.fromFoldable bs)
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer p v (L.List (SD.Block v))
            item bs = HH.li_ <$> traverse renderBlock (A.fromFoldable bs)
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.name l, HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue =
          case _ of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             field' → field'

renderRadioButton
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderRadioButton label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.inputType HP.InputRadio
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.RadioButtonChanged label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderCheckBox label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.inputType HP.InputCheckbox
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.CheckBoxChanged label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → H.HTML p (SDQ.SlamDownQuery v)
renderDropDown id label ls sel =
  HH.select
    [ HP.id_ id
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.DropDownChanged label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → H.HTML p (SDQ.SlamDownQuery v)
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → H.HTML p (SDQ.SlamDownQuery v)
    option' sel' value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel'), HP.value renderedValue ] [ HH.text renderedValue ]

renderFormElement
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer p v (SDS.FormFieldValue v)
renderFormElement config st id label field =
  case field of
    SD.TextBox tb →
      pure $ renderTextInput tb
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.className "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.className "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown id label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown id label options $ M.Just sel

  where
    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → H.HTML p (SDQ.SlamDownQuery v)
    renderTextInput tb =
      HH.input $
        [ HP.inputType compatibleInputType
        , HP.id_ id
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.TextBoxChanged label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        -- type signature required due to https://github.com/purescript/purescript/issues/2252
        typeSettings :: forall r i. Array (HP.IProp r i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [secondsStep]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [secondsStep]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

secondsStep ∷ forall r i. HP.IProp r i
secondsStep = refine $ HC.Attr M.Nothing (HC.attrName "step") "1"
  where
  refine :: HC.Prop i -> HP.IProp r i
  refine = unsafeCoerce

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ g v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component (SDS.SlamDownState v) (SDQ.SlamDownQuery v) g
slamDownComponent config =
  H.component
    { render: renderSlamDown config
    , eval: evalSlamDownQuery
    }

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures

  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.Either as E
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V

import Halogen as H
import Halogen.HTML.Core as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

import Unsafe.Coerce (unsafeCoerce)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ g v
  . (SD.Value v)
  ⇒ SDQ.SlamDownQuery v
  ~> H.ComponentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) g
evalSlamDownQuery e =
  case e of
    SDQ.TextBoxChanged key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      pure next

    SDQ.RadioButtonChanged key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      pure next

    SDQ.DropDownChanged key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      pure next

    SDQ.CheckBoxChanged key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        let
          desc = SDS.formDescFromDocument document
          keysToPrune = L.filter (\newKey → not (newKey `SM.member` desc)) (L.fromFoldable (SM.keys values))
          prunedValues = F.foldr SM.delete values keysToPrune
        in
          SDS.SlamDownState
            { document
            , formState: prunedValues
            }
      pure next

    SDQ.SetDocument doc next → do
      H.modify $ SDS.replaceDocument doc
      pure next

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer p v a = a → Fresh.Fresh (H.HTML p (SDQ.SlamDownQuery v))

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → H.ComponentHTML (SDQ.SlamDownQuery v)
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        <<< Fresh.runFresh config.formName
        <<< traverse renderBlock
          $ A.fromFoldable bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ ∀ p a. Int → Array (H.HTML p a) → H.HTML p a
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ ∀ p a. SD.ListType → Array (H.HTML p a) → H.HTML p a
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ ∀ p. FreshRenderer p v (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label req def → do
          ident ← Fresh.fresh
          let
            unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
            quote = SD.transFormField (unwrap >>> SD.Literal)
            field =
              unquote <<< ensureValidField <<< M.maybe def quote $
                SM.lookup label state.formState <|> SM.lookup label defaultFormState
          el ←
            case field of
              M.Nothing → pure $ HH.text "Unsupported form element"
              M.Just fv → renderFormElement config state ident label fv

          let
            requiredLabel = if req then "*" else ""
            requiresId =
              case field of
                M.Just (SD.CheckBoxes _ _) → false
                M.Just (SD.RadioButtons _ _) → false
                _ → true

          pure $ HH.span
            [ HP.class_ (HH.className "slamdown-field") ]
            [ HH.label
              (if requiresId then [ HP.for ident ] else [])
              [ HH.text (label <> requiredLabel) ]
            , el
            ]

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ ∀ p. FreshRenderer p v (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> traverse renderBlock (A.fromFoldable bs)
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer p v (L.List (SD.Block v))
            item bs = HH.li_ <$> traverse renderBlock (A.fromFoldable bs)
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.name l, HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue field =
          case field of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             _ → field

renderRadioButton
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderRadioButton label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.inputType HP.InputRadio
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.RadioButtonChanged label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderCheckBox label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.inputType HP.InputCheckbox
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.CheckBoxChanged label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → H.HTML p (SDQ.SlamDownQuery v)
renderDropDown id label ls sel =
  HH.select
    [ HP.id_ id
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.DropDownChanged label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → H.HTML p (SDQ.SlamDownQuery v)
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → H.HTML p (SDQ.SlamDownQuery v)
    option' sel value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel), HP.value renderedValue ] [ HH.text renderedValue ]

renderFormElement
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer p v (SDS.FormFieldValue v)
renderFormElement config st id label field =
  case field of
    SD.TextBox tb →
      pure $ renderTextInput tb
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.className "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.className "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown id label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown id label options $ M.Just sel

  where
    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → H.HTML p (SDQ.SlamDownQuery v)
    renderTextInput tb =
      HH.input $
        [ HP.inputType compatibleInputType
        , HP.id_ id
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.TextBoxChanged label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        -- type signature required due to https://github.com/purescript/purescript/issues/2252
        typeSettings :: forall r i. Array (HP.IProp r i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [secondsStep]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [secondsStep]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

secondsStep ∷ forall r i. HP.IProp r i
secondsStep = refine $ HC.Attr M.Nothing (HC.attrName "step") "1"
  where
  refine :: HC.Prop i -> HP.IProp r i
  refine = unsafeCoerce

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ g v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component (SDS.SlamDownState v) (SDQ.SlamDownQuery v) g
slamDownComponent config =
  H.component
    { render: renderSlamDown config
    , eval: evalSlamDownQuery
    }