trying to add support for patterns like '(Foo 1 2, Bar 3 4)'

lets see, what it breaks :D

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ binding' bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent (binding' bnd))
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent (binding' bnd)) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent (binding' bnd)
  indent $ char ','
  bs <- (indent (binding' bnd)) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  n <- indent typeName
  as   <- many (indent bnd)
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

-- TODO:
-- There is no support for patterns like
--  (Foo 1 2, Bar 3 4)
-- yet; for now, the constructors must be written in parantheses like
--  ((Foo 1 2), (Bar 3 4))
----
-- FIX THIS!
--
binding' :: FixedIndentParser String (Binding MType)
binding' bnd =
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ ilexe (char '(') *> constrLit bnd <* ilexe (char ')'))
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  ilexe $ char '('
  n <- indent typeName
  as   <- many (indent bnd)
  ilexe $ char ')'
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  ilexe $ char '('
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  ilexe $ char ')'
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

-- TODO:
-- There is no support for patterns like
--  (Foo 1 2, Bar 3 4)
-- yet; for now, the constructors must be written in parantheses like
--  ((Foo 1 2), (Bar 3 4))
----
-- FIX THIS!

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms


Add a Newtype instance to StatusCode

Add a Newtype instance to StatusCode

Makes it easier for users of the library to access the underlying
statuscode with `unwrap`.

module Affjax.StatusCode where

import Prelude
import Data.Newtype (class Newtype)

newtype StatusCode = StatusCode Int

derive instance eqStatusCode :: Eq StatusCode
derive instance ordStatusCode :: Ord StatusCode
derive instance newtypeStatusCode :: Newtype StatusCode _

instance showStatusCode :: Show StatusCode where
  show (StatusCode code) = "(StatusCode " <> show code <> ")"

module Affjax.StatusCode where

import Prelude

newtype StatusCode = StatusCode Int

derive instance eqStatusCode :: Eq StatusCode
derive instance ordStatusCode :: Ord StatusCode

instance showStatusCode :: Show StatusCode where
  show (StatusCode code) = "(StatusCode " <> show code <> ")"


+ a couple of http methods

+ a couple of http methods

module Node.Express.Types where

import Data.Foreign
import Data.Foreign.Class
import Data.Either
import Data.Foreign.EasyFFI
import Data.String.Regex
import Data.Default
import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Class

foreign import data Express :: !

--| General monad, indicates that we're dealing with
--  express.js related functions.
--  Applications should use HandlerM and AppM primarily
--  and ExpressM in rare cases.
type ExpressM a = forall e. Eff (express :: Express | e) a

instance monadEffExpressM :: MonadEff (Eff e) where
    liftEff = unsafeInterleaveEff

foreign import data Application :: *
foreign import data Event :: *
foreign import data Response :: *
foreign import data Request :: *

data Protocol = Http | Https

instance isForeignProtocol :: IsForeign Protocol where
    read value = case readString value of
        Right "http"  -> Right Http
        Right "https" -> Right Https
        _ -> Left $ JSONError "Unknown protocol"

data Method = ALL | GET | POST | PUT | DELETE | OPTIONS | HEAD | TRACE | CustomMethod String

instance showMethod :: Show Method where
    show ALL     = "all"
    show GET     = "get"
    show POST    = "post"
    show PUT     = "put"
    show DELETE  = "delete"
    show OPTIONS = "options"
    show HEAD    = "head"
    show TRACE   = "trace"
    show (CustomMethod method) = method

instance isForeignMethod :: IsForeign Method where
    read value = case readString value of
        Right "GET"     -> Right GET
        Right "POST"    -> Right POST
        Right "PUT"     -> Right PUT
        Right "DELETE"  -> Right DELETE
        Right "OPTIONS" -> Right OPTIONS
        Right "HEAD"    -> Right HEAD
        Right "TRACE"   -> Right TRACE
        Right method    -> Right $ CustomMethod method
        _ -> Left $ JSONError "Unknown HTTP method"

type Port = Number
type Path = String

class RoutePattern a
instance routePath  :: RoutePattern String
instance routeRegex :: RoutePattern Regex

class RequestParam a
instance requestParamString :: RequestParam String
instance requestParamNumber :: RequestParam Number

--| Cookie options
--  - maxAge -- time in msecs
--  - signed -- use secret to sign if true
--  - path   -- cookie path
newtype CookieOptions = CookieOptions { maxAge :: Number, signed :: Boolean, path :: String }

instance defaultCookieOptions :: Default CookieOptions where
    def = CookieOptions { maxAge: oneYear, signed: false, path: "/" }
      where oneYear = 365 * 24 * 60 * 60 * 1000

module Node.Express.Types where

import Data.Foreign
import Data.Foreign.Class
import Data.Either
import Data.Foreign.EasyFFI
import Data.String.Regex
import Data.Default
import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Class

foreign import data Express :: !

--| General monad, indicates that we're dealing with
--  express.js related functions.
--  Applications should use HandlerM and AppM primarily
--  and ExpressM in rare cases.
type ExpressM a = forall e. Eff (express :: Express | e) a

instance monadEffExpressM :: MonadEff (Eff e) where
    liftEff = unsafeInterleaveEff

foreign import data Application :: *
foreign import data Event :: *
foreign import data Response :: *
foreign import data Request :: *

data Protocol = Http | Https

instance isForeignProtocol :: IsForeign Protocol where
    read value = case readString value of
        Right "http"  -> Right Http
        Right "https" -> Right Https
        _ -> Left $ JSONError "Unknown protocol"

data Method = ALL | GET | POST | PUT | DELETE

instance showMethod :: Show Method where
    show ALL    = "all"
    show GET    = "get"
    show POST   = "post"
    show PUT    = "put"
    show DELETE = "delete"

instance isForeignMethod :: IsForeign Method where
    read value = case readString value of
        Right "GET"    -> Right GET
        Right "POST"   -> Right POST
        Right "PUT"    -> Right PUT
        Right "DELETE" -> Right DELETE
        _ -> Left $ JSONError "Unknown HTTP method"

type Port = Number
type Path = String

class RoutePattern a
instance routePath  :: RoutePattern String
instance routeRegex :: RoutePattern Regex

class RequestParam a
instance requestParamString :: RequestParam String
instance requestParamNumber :: RequestParam Number

--| Cookie options
--  - maxAge -- time in msecs
--  - signed -- use secret to sign if true
--  - path   -- cookie path
newtype CookieOptions = CookieOptions { maxAge :: Number, signed :: Boolean, path :: String }

instance defaultCookieOptions :: Default CookieOptions where
    def = CookieOptions { maxAge: oneYear, signed: false, path: "/" }
      where oneYear = 365 * 24 * 60 * 60 * 1000


Added known issue to FT

Added known issue to FT

{-
Copyright 2015 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 Test.SlamData.Feature.Test.Markdown where

import Data.String (joinWith)
import Control.Apply ((*>))
import Prelude
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Expectations as Expect
import Test.Feature.Scenario (scenario)

mdScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
mdScenario =
  scenario
    "Markdown"
    (Interact.createWorkspaceInTestFolder "Markdown")
    (Interact.deleteFileInTestFolder "Markdown.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  mdScenario "Provide and play markdown" ["https://github.com/slamdata/slamdata/issues/987"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard
      $ joinWith "\n\n"
          [ "discipline = __"
          , "sport = __ (Bobsleigh)"
          , "age = #__"
          , "year = #__ (2002)"
          , "startDate = __ - __ - __"
          , "finishDate = __ - __ - __ (2002-06-06)"
          , "startTime = __ : __"
          , "finishTime = __ : __ (20:39)"
          , "event = {1000m, 1500m, 3000m} (1500m)"
          , "gender = []M []W []X"
          , "color = [x]Red []Green [x]Blue"
          , "type = (x)Gold ()Silver ()Bronze"
          ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" ""
    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    Expect.fieldInLastMdCard "age" "number" ""
    Expect.fieldInLastMdCard "year" "number" "2002"
    Expect.fieldInLastMdCard "startDate" "date" ""
    Expect.fieldInLastMdCard "finishDate" "date" "2002-06-06"
    Expect.fieldInLastMdCard "startTime" "time" ""
    Expect.fieldInLastMdCard "finishTime" "time" "20:39"
    Expect.labelInLastMdCard "event"
    Expect.dropdownInLastMdCard "1500m" ["1000m", "1500m", "3000m"]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" false
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "color"
    Expect.checkableFieldInLastMdCard "Red" "checkbox" true
    Expect.checkableFieldInLastMdCard "Green" "checkbox" false
    Expect.checkableFieldInLastMdCard "Blue" "checkbox" true
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" true
    Expect.checkableFieldInLastMdCard "Silver" "radio" false
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false

    successMsg "Ok, succesfully provided and played markdown."

  mdScenario "Change and play markdown" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "discipline = __"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideMdInLastMdCard "sport =  __ (Bobsleigh)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck

    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    successMsg "Ok, successfully changed and played markdown."

  mdScenario "Provide and play markdown with evaluated content" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" "Figure skating"
    Expect.fieldInLastMdCard "year" "text" "1924"
    Expect.labelInLastMdCard "country"
    Expect.dropdownInLastMdCard "AUT"
      [ "LAT"
      , "CZE"
      , "UKR"
      , "SLO"
      , "RUS"
      , "SVK"
      , "KAZ"
      , "AUS"
      , "LUX"
      , "UZB"
      , "EUN"
      , "DEN"
      , "CHN"
      , "ROU"
      , "GDR"
      , "PRK"
      , "CRO"
      , "URS"
      , "BLR"
      , "BUL"
      , "POL"
      , "EUA"
      , "KOR"
      , "NED"
      , "ITA"
      , "FRG"
      , "EST"
      , "SWE"
      , "GBR"
      , "TCH"
      , "BEL"
      , "FIN"
      , "USA"
      , "YUG"
      , "SUI"
      , "LIE"
      , "CAN"
      , "JPN"
      , "HUN"
      , "GER"
      , "NOR"
      , "NZL"
      , "FRA"
      , "AUT"
      , "ESP"
      ]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" true
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" false
    Expect.checkableFieldInLastMdCard "Silver" "radio" true
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false
    successMsg "Ok, successfully provided and played markdown with evaluated content"

  mdScenario "Filter query results with default field values" ["https://github.com/slamdata/slamdata/issues/1193"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "discipline"
    Interact.addColumn "country"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 2 "discipline" "Figure skating"
    Expect.cardsInTableColumnInLastCardToEq 2 "country" "AUT"
    Expect.cardsInTableColumnInLastCardToEq 2 "gender" "W"
    Expect.cardsInTableColumnInLastCardToBeGT 2 "year" "1924"
    Expect.cardsInTableColumnInLastCardToNotEq 2 "type" "Silver"
    successMsg "Ok, Filtered query results with fields"

  mdScenario "Filter query results by changing field values" ["https://github.com/slamdata/slamdata/issues/1194"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard

    Interact.addColumn "discipline"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.addColumn "country"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideFieldValueInLastDeck "discipline" "Luge"
    Interact.provideFieldValueInLastDeck "year" "1950"
    Interact.uncheckFieldInLastDeck "W"
    Interact.checkFieldInLastDeck "X"
    Interact.checkFieldInLastDeck "M"
    Interact.pushRadioButtonInLastDeck "Gold"
    Interact.selectFromDropdownInLastDeck "country" "GDR"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 8 "discipline" "Luge"
    Expect.cardsInTableColumnInLastCardToEqOneOf 8 "gender" ["M", "X"]
    Expect.cardsInTableColumnInLastCardToBeGT 8 "year" "1950"
    Expect.cardsInTableColumnInLastCardToNotEq 8 "type" "Gold"
    successMsg "Ok, Filtered query results by changing field values"

  mdScenario "Markdown chaining" [] do
    let
      states = ["MA", "MN", "SC", "RI", "OK", "SD", "NH", "ME", "NJ", "VT", "CA", "CT", "CO", "PA", "LA", "NY", "DE", "DC", "OR", "MD", "VA", "WV", "NC", "NE", "GA", "TX", "FL", "AL", "TN", "MS", "AK", "KY", "AZ", "OH", "IN", "MI", "IA", "KS", "WI", "ND", "MT", "IL", "UT", "MO", "AR", "NM", "WY", "ID", "NV", "HI", "WA"]
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "state = {!``select distinct state from `/test-mount/testDb/zips` order by asc``}"
      <> "(!``select state from `/test-mount/testDb/zips` limit 1 ``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.dropdownInLastMdCard "MA" states
    Interact.accessNextCardInLastDeck
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "city = ___"
      <> "(!``select city from `/test-mount/testDb/zips` where state = :state order by asc limit 1``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "AGAWAM"
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.selectFromDropdownInLastDeck "state" "RI"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "ASHAWAY"
    successMsg "Ok, variables from md card could be used in md card"

{-
Copyright 2015 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 Test.SlamData.Feature.Test.Markdown where

import Data.String (joinWith)
import Control.Apply ((*>))
import Prelude
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Expectations as Expect
import Test.Feature.Scenario (scenario)

mdScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
mdScenario =
  scenario
    "Markdown"
    (Interact.createWorkspaceInTestFolder "Markdown")
    (Interact.deleteFileInTestFolder "Markdown.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  mdScenario "Provide and play markdown" ["https://github.com/slamdata/slamdata/issues/987"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard
      $ joinWith "\n\n"
          [ "discipline = __"
          , "sport = __ (Bobsleigh)"
          , "age = #__"
          , "year = #__ (2002)"
          , "startDate = __ - __ - __"
          , "finishDate = __ - __ - __ (2002-06-06)"
          , "startTime = __ : __"
          , "finishTime = __ : __ (20:39)"
          , "event = {1000m, 1500m, 3000m} (1500m)"
          , "gender = []M []W []X"
          , "color = [x]Red []Green [x]Blue"
          , "type = (x)Gold ()Silver ()Bronze"
          ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" ""
    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    Expect.fieldInLastMdCard "age" "number" ""
    Expect.fieldInLastMdCard "year" "number" "2002"
    Expect.fieldInLastMdCard "startDate" "date" ""
    Expect.fieldInLastMdCard "finishDate" "date" "2002-06-06"
    Expect.fieldInLastMdCard "startTime" "time" ""
    Expect.fieldInLastMdCard "finishTime" "time" "20:39"
    Expect.labelInLastMdCard "event"
    Expect.dropdownInLastMdCard "1500m" ["1000m", "1500m", "3000m"]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" false
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "color"
    Expect.checkableFieldInLastMdCard "Red" "checkbox" true
    Expect.checkableFieldInLastMdCard "Green" "checkbox" false
    Expect.checkableFieldInLastMdCard "Blue" "checkbox" true
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" true
    Expect.checkableFieldInLastMdCard "Silver" "radio" false
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false

    successMsg "Ok, succesfully provided and played markdown."

  mdScenario "Change and play markdown" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "discipline = __"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideMdInLastMdCard "sport =  __ (Bobsleigh)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck

    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    successMsg "Ok, successfully changed and played markdown."

  mdScenario "Provide and play markdown with evaluated content" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" "Figure skating"
    Expect.fieldInLastMdCard "year" "text" "1924"
    Expect.labelInLastMdCard "country"
    Expect.dropdownInLastMdCard "AUT"
      [ "LAT"
      , "CZE"
      , "UKR"
      , "SLO"
      , "RUS"
      , "SVK"
      , "KAZ"
      , "AUS"
      , "LUX"
      , "UZB"
      , "EUN"
      , "DEN"
      , "CHN"
      , "ROU"
      , "GDR"
      , "PRK"
      , "CRO"
      , "URS"
      , "BLR"
      , "BUL"
      , "POL"
      , "EUA"
      , "KOR"
      , "NED"
      , "ITA"
      , "FRG"
      , "EST"
      , "SWE"
      , "GBR"
      , "TCH"
      , "BEL"
      , "FIN"
      , "USA"
      , "YUG"
      , "SUI"
      , "LIE"
      , "CAN"
      , "JPN"
      , "HUN"
      , "GER"
      , "NOR"
      , "NZL"
      , "FRA"
      , "AUT"
      , "ESP"
      ]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" true
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" false
    Expect.checkableFieldInLastMdCard "Silver" "radio" true
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false
    successMsg "Ok, successfully provided and played markdown with evaluated content"

  mdScenario "Filter query results with default field values" ["https://github.com/slamdata/slamdata/issues/1193"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "discipline"
    Interact.addColumn "country"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 2 "discipline" "Figure skating"
    Expect.cardsInTableColumnInLastCardToEq 2 "country" "AUT"
    Expect.cardsInTableColumnInLastCardToEq 2 "gender" "W"
    Expect.cardsInTableColumnInLastCardToBeGT 2 "year" "1924"
    Expect.cardsInTableColumnInLastCardToNotEq 2 "type" "Silver"
    successMsg "Ok, Filtered query results with fields"

  mdScenario "Filter query results by changing field values" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard

    Interact.addColumn "discipline"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.addColumn "country"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideFieldValueInLastDeck "discipline" "Luge"
    Interact.provideFieldValueInLastDeck "year" "1950"
    Interact.uncheckFieldInLastDeck "W"
    Interact.checkFieldInLastDeck "X"
    Interact.checkFieldInLastDeck "M"
    Interact.pushRadioButtonInLastDeck "Gold"
    Interact.selectFromDropdownInLastDeck "country" "GDR"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 8 "discipline" "Luge"
    Expect.cardsInTableColumnInLastCardToEqOneOf 8 "gender" ["M", "X"]
    Expect.cardsInTableColumnInLastCardToBeGT 8 "year" "1950"
    Expect.cardsInTableColumnInLastCardToNotEq 8 "type" "Gold"
    successMsg "Ok, Filtered query results by changing field values"

  mdScenario "Markdown chaining" [] do
    let
      states = ["MA", "MN", "SC", "RI", "OK", "SD", "NH", "ME", "NJ", "VT", "CA", "CT", "CO", "PA", "LA", "NY", "DE", "DC", "OR", "MD", "VA", "WV", "NC", "NE", "GA", "TX", "FL", "AL", "TN", "MS", "AK", "KY", "AZ", "OH", "IN", "MI", "IA", "KS", "WI", "ND", "MT", "IL", "UT", "MO", "AR", "NM", "WY", "ID", "NV", "HI", "WA"]
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "state = {!``select distinct state from `/test-mount/testDb/zips` order by asc``}"
      <> "(!``select state from `/test-mount/testDb/zips` limit 1 ``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.dropdownInLastMdCard "MA" states
    Interact.accessNextCardInLastDeck
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "city = ___"
      <> "(!``select city from `/test-mount/testDb/zips` where state = :state order by asc limit 1``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "AGAWAM"
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.selectFromDropdownInLastDeck "state" "RI"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "ASHAWAY"
    successMsg "Ok, variables from md card could be used in md card"


Export `toArray` from HTMLCollection (#113)

... Oops. Previously, `toArray` wasn't exported. This has now been
corrected.

module DOM.Node.HTMLCollection
  ( length
  , item
  , namedItem
  , toArray
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)
import DOM (DOM)
import DOM.Node.Types (Element, HTMLCollection, ElementId)

-- | The number of elements in a HTMLCollection.
foreign import length :: forall eff. HTMLCollection -> Eff (dom :: DOM | eff) Int

-- | The elements of an HTMLCollection represented in an array.
foreign import toArray :: forall eff. HTMLCollection -> Eff (dom :: DOM | eff) (Array Element)

-- | The element in a HTMLCollection at the specified index, or Nothing if no such
-- | element exists.
item :: forall eff. Int -> HTMLCollection -> Eff (dom :: DOM | eff) (Maybe Element)
item i = map toMaybe <<< _item i

foreign import _item :: forall eff. Int -> HTMLCollection -> Eff (dom :: DOM | eff) (Nullable Element)

-- | The first element with the specified name or ID in a HTMLCollection, or
-- | Nothing if no such element exists.
namedItem :: forall eff. ElementId -> HTMLCollection -> Eff (dom :: DOM | eff) (Maybe Element)
namedItem id = map toMaybe <<< _namedItem id

foreign import _namedItem :: forall eff. ElementId -> HTMLCollection -> Eff (dom :: DOM | eff) (Nullable Element)

module DOM.Node.HTMLCollection
  ( length
  , item
  , namedItem
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)
import DOM (DOM)
import DOM.Node.Types (Element, HTMLCollection, ElementId)

-- | The number of elements in a HTMLCollection.
foreign import length :: forall eff. HTMLCollection -> Eff (dom :: DOM | eff) Int

-- | The elements of an HTMLCollection represented in an array.
foreign import toArray :: forall eff. HTMLCollection -> Eff (dom :: DOM | eff) (Array Element)

-- | The element in a HTMLCollection at the specified index, or Nothing if no such
-- | element exists.
item :: forall eff. Int -> HTMLCollection -> Eff (dom :: DOM | eff) (Maybe Element)
item i = map toMaybe <<< _item i

foreign import _item :: forall eff. Int -> HTMLCollection -> Eff (dom :: DOM | eff) (Nullable Element)

-- | The first element with the specified name or ID in a HTMLCollection, or
-- | Nothing if no such element exists.
namedItem :: forall eff. ElementId -> HTMLCollection -> Eff (dom :: DOM | eff) (Maybe Element)
namedItem id = map toMaybe <<< _namedItem id

foreign import _namedItem :: forall eff. ElementId -> HTMLCollection -> Eff (dom :: DOM | eff) (Nullable Element)


Use SQL syntax for Ace

Use SQL syntax for Ace

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), EAce(), Editor(), TextMode())
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

foreign import markdownMode """
  var markdownMode = "ace/mode/markdown";
""" :: TextMode

foreign import sqlMode """
  var sqlMode = "ace/mode/sql";
""" :: TextMode

foreign import plainTextMode """
  var plainTextMode = "ace/mode/plain_text";
""" :: TextMode

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  "query" -> sqlMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: EAce | eff) ->
              Eff (HalogenEffects (ace :: EAce | eff)) Unit
initialize m b d = do
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: EAce | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: EAce | eff) -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), EAce(), Editor(), TextMode())
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

foreign import markdownMode """
  var markdownMode = "ace/mode/markdown";
""" :: TextMode
foreign import plainTextMode """
  var plainTextMode = "ace/mode/plain_text";
""" :: TextMode

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: EAce | eff) ->
              Eff (HalogenEffects (ace :: EAce | eff)) Unit
initialize m b d = do
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: EAce | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: EAce | eff) -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)