Defined IndexingParserT

Defined IndexingParserT

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 (State, StateT, runState, runStateT, get, put, modify, lift)

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, anyChar)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos, Position)

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

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

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

type IndexingT m a = StateT Int m a

type IndexingParserT s m a = IndexintT (ParserT s m) a

runIndexingT :: forall m a. (Monad m) => IndexingT m a -> m (Tuple a Int)
runIndexingT action = runStateT action 0

type IndentParser s a = IndexingT (ParserT s (State Position)) a

fresh :: forall m. (Monad m) => IndexingT m Int
fresh = do
  i <- get
  modify (\i -> i + 1)
  pure i

freshMeta :: forall m. (Monad m) => IndexingT m Meta
freshMeta = AST.idxMeta <$> fresh

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

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

-- returns the next non whitespace character
lookAhead :: forall m. (Monad m) => ParserT String m Char
lookAhead = PC.lookAhead $ whiteSpace *> anyChar

---------------------------------------------------------
-- 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
upperCaseName :: forall m. (Monad m) => ParserT String m String
upperCaseName = 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 data constructors
constructor :: forall m. (Monad m) => ParserT String m Atom
constructor = Constr <$> upperCaseName

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> constructor <|> 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) (String -> Op) Assoc))
infixOperators =
  [ [ (tuple3 (PC.try infixConstructor) InfixConstr AssocLeft)
    , (tuple3 (PC.try infixFunc) InfixFunc AssocLeft)
    , (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) (const Composition) AssocRight) ]
  , [ (tuple3 (string "^") (const Power) AssocRight) ]
  , [ (tuple3 (string "*") (const Mul) AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) (const Add) AssocLeft)
    , (tuple3 (string "-") (const Sub) AssocLeft)
    ]
  , [ (tuple3 (string ":") (const Colon) AssocRight)
    , (tuple3 (string "++") (const Append) AssocRight)
    ]
  , [ (tuple3 (string "==") (const Equ) AssocNone)
    , (tuple3 (string "/=") (const Neq) AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) (const Lt) AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) (const Gt) AssocNone)
    , (tuple3 (string "<=") (const Leq) AssocNone)
    , (tuple3 (string ">=") (const Geq) AssocNone)
    ]
  , [ (tuple3 (string "&&") (const And) AssocRight) ]
  , [ (tuple3 (string "||") (const Or) AssocRight) ]
  , [ (tuple3 (string "$") (const Dollar) AssocRight) ]
  ]

infixFunc :: forall m. (Monad m) => ParserT String m String
infixFunc = char '`' *> name <* char '`'

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable m String TypeTree
    infixTable =
      (\x ->
        (uncurry3
          (\p op assoc ->
            Infix (do
                  meta <- freshMeta
                  Binary freshMeta <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

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

    -- | 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 _ -> op <$> p)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators

-- | 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
  <|> (do
      meta <- freshMeta
      Atom meta <$> 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 -> do
      meta <- freshMeta
      pure $ App meta 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
  meta <- freshMeta
  pure $ IfExpr meta 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 -> do
      meta <- freshMeta
      pure $ NTuple meta (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 -> do
      meta <- freshMeta
      case me2 of
        Nothing -> pure $ PrefixOp meta op
        Just e2 -> pure $ SectR meta op e2
    Just e1 ->
      case me2 of
        Nothing -> do
          meta <- freshMeta
          pure $ SectL meta 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 ']'
  meta <- freshMeta
  pure $ List meta 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 ']'
  meta <- freshMeta
  pure $ ArithmSeq meta 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 ']'
  meta <- freshMeta
  pure $ ListComp meta 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
          meta <- freshMeta
          pure $ Let meta b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          meta <- freshMeta
          pure $ Gen meta b e
        parseGuard = do
          meta <- freshMeta
          expr' <- ilexe expr
          pure $ Guard meta expr'

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  meta1 <- freshMeta
  meta2 <- freshMeta
  pure (List meta1 ((Atom meta2 <<< 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
  meta <- freshMeta
  pure $ Lambda meta 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
  meta <- freshMeta
  pure $ LetExpr meta binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding Meta) 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 Meta) 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 (Tuple a Int)
runParserIndent p src = fst $ flip runState initialPos $ runParserT src $ runIndexingT p

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

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------
-- Grammar
----------
{-
<BINDING>
  ::= <SIMPLE>
    | `[` <LIST> `]`
    | `(` <LIST> `)`

<SIMPLE>
  ::= <LIT>

<LIST>
  ::= <CONSES> { `,` <CONSES> }

<CONSES>
  ::= <INFIXES> { `:` <INFIXES> }

<INFIXES>
  ::= { <COMPLEX> <INF_CONSTR> } <COMPLEX>

<COMPLEX>
  ::= <CONSTR> { <BINDING> }
    | <BINDING>
-}

binding :: IndentParser String (Binding Meta)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> NTupleLit <$> freshMeta <*> pure Nil
                 Cons c Nil -> pure c
                 cs'        -> NTupleLit <$> freshMeta <*> pure cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> ListLit <$> freshMeta <*> pure Nil
                 cs'        -> ListLit <$> freshMeta <*> pure cs'
         _   -> PC.try $ ilexe bndSimple

bndSimple :: IndentParser String (Binding Meta)
bndSimple = PC.try bndLit

bndLit :: forall m. (Monad m) => ParserT String m (Binding Meta)
bndLit = Lit <$> freshMeta <*> atom

bndList :: IndentParser String (Binding Meta) -> IndentParser String (List (Binding Meta))
bndList bnd = PC.sepBy
  (PC.try <<< indent <<< bndConses $ bnd)
  (PC.try <<< indent <<< char $ ',')

bndConses :: FixedIndentParser String (Binding Meta)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      ConsLit <$> freshMeta)

bndInfixes :: FixedIndentParser String (Binding Meta)
bndInfixes bnd = PC.chainl1
  (PC.try (ilexe ((bndComplex bnd))))
  (do o <- PC.try (indent infixConstructor)
      meta <- freshMeta
      pure (\l r -> ConstrLit meta (InfixDataConstr o LEFTASSOC 9 l r)))

bndComplex :: FixedIndentParser String (Binding Meta)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        meta <- freshMeta
        pure $ ConstrLit meta (PrefixDataConstr n (length as) as))
  <|> indent bnd

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

typeDefinition' :: IndentParser String (List Definition)
typeDefinition' = compileADTDef <$> typeDefinition

-- TODO: Infix function definition

definitions :: IndentParser String (List Definition)
definitions = do
  skipWhite
  defs <- many $ (PC.try typeDefinition') <|> (pure <$> definition)
  pure $ concat defs

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

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
-- Grammar
----------
{-
<TYPE>
  ::= <TYPE1> [ `->` <TYPE> ]

<TYPE1>
  ::= <SIMPLE>
    | `[` <TYPE> `]`
    | `(` <TYPE> { `,` <TYPE> } `)`
    | <CONS> { <TYPE> }

<SIMPLE>
  ::= `Int` | `Bool` | `Char` | <TYPEVAR>
-}

type1 :: FixedIndentParser String Type
type1 t = do
  la <- lookAhead
  case la of
       '(' -> do
          ts <- PC.between
            (PC.try <<< ilexe <<< char $ '(')
            (PC.try <<< indent <<< char $ ')')
            (indent t `PC.sepBy1` (PC.try <<< indent <<< char) ',')
          case ts of
               Nil         -> fail "Empty Tuple"
               Cons t' Nil -> pure t'
               ts'         -> (pure <<< TTuple) ts'
       '[' -> PC.between
          (PC.try <<< ilexe <<< char $ '[')
          (PC.try <<< indent <<< char $ ']')
          (TList <$> indent t)
       _ -> (PC.try <<< indent) simpleType <|> (indent <<< typeCons) t

simpleType :: IndentParser String Type
simpleType = do
  la <- lookAhead
  case la of
       'B' -> TypCon <$> string "Bool"
       'I' -> TypCon <$> string "Int"
       'C' -> TypCon <$> string "Char"
       _   -> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe upperCaseName
  ps <- many <<< indent $ types1 t <|> simpleType
  pure $ TTypeCons n ps

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

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

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (do ts <- indent t `PC.sepBy1` (PC.try <<< indent <<< char) ','
      case ts of
           Nil        -> fail "Empty Tuple"
           Cons x Nil -> pure x
           xs         -> (pure <<< TTuple) xs)

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

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------
-- Grammar
----------
{-
<TYPEDEFINITION>
  ::= 'data' <UCASENAME> { <NAME> } [ '=' <CONSTR> { '|' <CONSTR> } ]

<CONSTR>
  ::= <PREFIXCONSTR>
    | <INFIXCONSTR>

<PREFIXCONSTR>
  ::= <UCASENAME> { <TYPE> }
    | <TYPE> <CONSTROP> <TYPE>

<CONSTROP>
  ::= ':' <SYMBOL> { <SYMBOL> }       (* at least one symbol after ':' is needed,
                                       * to no confuse it with a list-(:).
                                       *)
-}

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent upperCaseName
  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 (DataConstr Type)
dataConstructorDefinition
  = PC.try prefixDataConstrtructorDefinition
  <|> infixDataConstrtructorDefinition

prefixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
prefixDataConstrtructorDefinition = do
  n <- ilexe upperCaseName
  ps <- many types
  pure $ PrefixDataConstr n (length ps) ps

infixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
infixDataConstrtructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixDataConstr o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many1 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 (State, StateT, runState, runStateT, get, put, modify, lift)

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, anyChar)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos, Position)

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

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

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

type IndexingT m a = StateT Int m a

runIndexingT :: forall m a. (Monad m) => IndexingT m a -> m (Tuple a Int)
runIndexingT action = runStateT action 0

type IndentParser s a = IndexingT (ParserT s (State Position)) a

fresh :: forall m. (Monad m) => IndexingT m Int
fresh = do
  i <- get
  modify (\i -> i + 1)
  pure i

freshMeta :: forall m. (Monad m) => IndexingT m Meta
freshMeta = AST.idxMeta <$> fresh

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

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

-- returns the next non whitespace character
lookAhead :: forall m. (Monad m) => ParserT String m Char
lookAhead = PC.lookAhead $ whiteSpace *> anyChar

---------------------------------------------------------
-- 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
upperCaseName :: forall m. (Monad m) => ParserT String m String
upperCaseName = 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 data constructors
constructor :: forall m. (Monad m) => ParserT String m Atom
constructor = Constr <$> upperCaseName

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> constructor <|> 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) (String -> Op) Assoc))
infixOperators =
  [ [ (tuple3 (PC.try infixConstructor) InfixConstr AssocLeft)
    , (tuple3 (PC.try infixFunc) InfixFunc AssocLeft)
    , (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) (const Composition) AssocRight) ]
  , [ (tuple3 (string "^") (const Power) AssocRight) ]
  , [ (tuple3 (string "*") (const Mul) AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) (const Add) AssocLeft)
    , (tuple3 (string "-") (const Sub) AssocLeft)
    ]
  , [ (tuple3 (string ":") (const Colon) AssocRight)
    , (tuple3 (string "++") (const Append) AssocRight)
    ]
  , [ (tuple3 (string "==") (const Equ) AssocNone)
    , (tuple3 (string "/=") (const Neq) AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) (const Lt) AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) (const Gt) AssocNone)
    , (tuple3 (string "<=") (const Leq) AssocNone)
    , (tuple3 (string ">=") (const Geq) AssocNone)
    ]
  , [ (tuple3 (string "&&") (const And) AssocRight) ]
  , [ (tuple3 (string "||") (const Or) AssocRight) ]
  , [ (tuple3 (string "$") (const Dollar) AssocRight) ]
  ]

infixFunc :: forall m. (Monad m) => ParserT String m String
infixFunc = char '`' *> name <* char '`'

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable m String TypeTree
    infixTable =
      (\x ->
        (uncurry3
          (\p op assoc ->
            Infix (do
                  meta <- freshMeta
                  Binary freshMeta <<< toOpTuple <<< op <$> spaced p) assoc))
        <$> x)
      <$> infixOperators

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

    -- | 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 _ -> op <$> p)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators

-- | 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
  <|> (do
      meta <- freshMeta
      Atom meta <$> 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 -> do
      meta <- freshMeta
      pure $ App meta 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
  meta <- freshMeta
  pure $ IfExpr meta 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 -> do
      meta <- freshMeta
      pure $ NTuple meta (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 -> do
      meta <- freshMeta
      case me2 of
        Nothing -> pure $ PrefixOp meta op
        Just e2 -> pure $ SectR meta op e2
    Just e1 ->
      case me2 of
        Nothing -> do
          meta <- freshMeta
          pure $ SectL meta 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 ']'
  meta <- freshMeta
  pure $ List meta 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 ']'
  meta <- freshMeta
  pure $ ArithmSeq meta 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 ']'
  meta <- freshMeta
  pure $ ListComp meta 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
          meta <- freshMeta
          pure $ Let meta b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          meta <- freshMeta
          pure $ Gen meta b e
        parseGuard = do
          meta <- freshMeta
          expr' <- ilexe expr
          pure $ Guard meta expr'

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  meta1 <- freshMeta
  meta2 <- freshMeta
  pure (List meta1 ((Atom meta2 <<< 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
  meta <- freshMeta
  pure $ Lambda meta 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
  meta <- freshMeta
  pure $ LetExpr meta binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding Meta) 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 Meta) 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 (Tuple a Int)
runParserIndent p src = fst $ flip runState initialPos $ runParserT src $ runIndexingT p

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

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------
-- Grammar
----------
{-
<BINDING>
  ::= <SIMPLE>
    | `[` <LIST> `]`
    | `(` <LIST> `)`

<SIMPLE>
  ::= <LIT>

<LIST>
  ::= <CONSES> { `,` <CONSES> }

<CONSES>
  ::= <INFIXES> { `:` <INFIXES> }

<INFIXES>
  ::= { <COMPLEX> <INF_CONSTR> } <COMPLEX>

<COMPLEX>
  ::= <CONSTR> { <BINDING> }
    | <BINDING>
-}

binding :: IndentParser String (Binding Meta)
binding = do
  whiteSpace
  fix $ \bnd -> do
    la <- lookAhead
    case la of
         '(' -> do
            cs <- ilexe (char '(') *> indent (bndList bnd) <* indent (char ')')
            case cs of
                 Nil        -> NTupleLit <$> freshMeta <*> pure Nil
                 Cons c Nil -> pure c
                 cs'        -> NTupleLit <$> freshMeta <*> pure cs'
         '[' -> do
            cs <- ilexe (char '[') *> indent (bndList bnd) <* indent (char ']')
            case cs of
                 Nil        -> ListLit <$> freshMeta <*> pure Nil
                 cs'        -> ListLit <$> freshMeta <*> pure cs'
         _   -> PC.try $ ilexe bndSimple

bndSimple :: IndentParser String (Binding Meta)
bndSimple = PC.try bndLit

bndLit :: forall m. (Monad m) => ParserT String m (Binding Meta)
bndLit = Lit <$> freshMeta <*> atom

bndList :: IndentParser String (Binding Meta) -> IndentParser String (List (Binding Meta))
bndList bnd = PC.sepBy
  (PC.try <<< indent <<< bndConses $ bnd)
  (PC.try <<< indent <<< char $ ',')

bndConses :: FixedIndentParser String (Binding Meta)
bndConses bnd = PC.chainr1
  (PC.try <<< ilexe <<< bndInfixes $ bnd)
  (do PC.try <<< indent <<< char $ ':'
      ConsLit <$> freshMeta)

bndInfixes :: FixedIndentParser String (Binding Meta)
bndInfixes bnd = PC.chainl1
  (PC.try (ilexe ((bndComplex bnd))))
  (do o <- PC.try (indent infixConstructor)
      meta <- freshMeta
      pure (\l r -> ConstrLit meta (InfixDataConstr o LEFTASSOC 9 l r)))

bndComplex :: FixedIndentParser String (Binding Meta)
bndComplex bnd =
  PC.try
    (do n  <- ilexe upperCaseName
        as <- many1 bnd
        meta <- freshMeta
        pure $ ConstrLit meta (PrefixDataConstr n (length as) as))
  <|> indent bnd

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

typeDefinition' :: IndentParser String (List Definition)
typeDefinition' = compileADTDef <$> typeDefinition

-- TODO: Infix function definition

definitions :: IndentParser String (List Definition)
definitions = do
  skipWhite
  defs <- many $ (PC.try typeDefinition') <|> (pure <$> definition)
  pure $ concat defs

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

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
-- Grammar
----------
{-
<TYPE>
  ::= <TYPE1> [ `->` <TYPE> ]

<TYPE1>
  ::= <SIMPLE>
    | `[` <TYPE> `]`
    | `(` <TYPE> { `,` <TYPE> } `)`
    | <CONS> { <TYPE> }

<SIMPLE>
  ::= `Int` | `Bool` | `Char` | <TYPEVAR>
-}

type1 :: FixedIndentParser String Type
type1 t = do
  la <- lookAhead
  case la of
       '(' -> do
          ts <- PC.between
            (PC.try <<< ilexe <<< char $ '(')
            (PC.try <<< indent <<< char $ ')')
            (indent t `PC.sepBy1` (PC.try <<< indent <<< char) ',')
          case ts of
               Nil         -> fail "Empty Tuple"
               Cons t' Nil -> pure t'
               ts'         -> (pure <<< TTuple) ts'
       '[' -> PC.between
          (PC.try <<< ilexe <<< char $ '[')
          (PC.try <<< indent <<< char $ ']')
          (TList <$> indent t)
       _ -> (PC.try <<< indent) simpleType <|> (indent <<< typeCons) t

simpleType :: IndentParser String Type
simpleType = do
  la <- lookAhead
  case la of
       'B' -> TypCon <$> string "Bool"
       'I' -> TypCon <$> string "Int"
       'C' -> TypCon <$> string "Char"
       _   -> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe upperCaseName
  ps <- many <<< indent $ types1 t <|> simpleType
  pure $ TTypeCons n ps

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

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

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe <<< char $ '(')
  (PC.try <<< indent <<< char $ ')')
  (do ts <- indent t `PC.sepBy1` (PC.try <<< indent <<< char) ','
      case ts of
           Nil        -> fail "Empty Tuple"
           Cons x Nil -> pure x
           xs         -> (pure <<< TTuple) xs)

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

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------
-- Grammar
----------
{-
<TYPEDEFINITION>
  ::= 'data' <UCASENAME> { <NAME> } [ '=' <CONSTR> { '|' <CONSTR> } ]

<CONSTR>
  ::= <PREFIXCONSTR>
    | <INFIXCONSTR>

<PREFIXCONSTR>
  ::= <UCASENAME> { <TYPE> }
    | <TYPE> <CONSTROP> <TYPE>

<CONSTROP>
  ::= ':' <SYMBOL> { <SYMBOL> }       (* at least one symbol after ':' is needed,
                                       * to no confuse it with a list-(:).
                                       *)
-}

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent upperCaseName
  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 (DataConstr Type)
dataConstructorDefinition
  = PC.try prefixDataConstrtructorDefinition
  <|> infixDataConstrtructorDefinition

prefixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
prefixDataConstrtructorDefinition = do
  n <- ilexe upperCaseName
  ps <- many types
  pure $ PrefixDataConstr n (length ps) ps

infixDataConstrtructorDefinition :: IndentParser String (DataConstr Type)
infixDataConstrtructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixDataConstr o LEFTASSOC 9 l r

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


Add launchAff_ and runSuspendedAff

Add launchAff_ and runSuspendedAff

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchSuspendedAff
  , runAff
  , runAff_
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  , run ∷ Eff eff Unit
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends n `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Convenience data

Convenience data

module Data.String.Regex (
  Regex(..),
  RegexFlags(..),
  regex,
  source,
  flags,
  renderFlags,
  parseFlags,
  test,
  match,
  replace,
  replace',
  search,
  split
  ) where

import Data.Function
import Data.Maybe
import Data.String (indexOf)

foreign import data Regex :: *

foreign import showRegex'
  """
  function showRegex$prime(r) {
    return '' + r;
  }
  """ :: Regex -> String

instance showRegex :: Show Regex where
  show = showRegex'

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

noFlags :: RegexFlags
noFlags = { global     : false
          , ignoreCase : false
          , multiline  : false
          , sticky     : false
          , unicode    : false }

foreign import regex'
  """
  function regex$prime(s1) {
    return function(s2) {
      return new RegExp(s1, s2);
    };
  }
  """ :: String -> String -> Regex

regex :: String -> RegexFlags -> Regex
regex source flags = regex' source $ renderFlags flags

foreign import source
  """
  function source(r) {
    return r.source;
  }
  """ :: Regex -> String

foreign import flags
  """
  function flags(r) {
    return {
      multiline: r.multiline,
      ignoreCase: r.ignoreCase,
      global: r.global,
      sticky: !!r.sticky,
      unicode: !!r.unicode
    };
  }
  """ :: Regex -> RegexFlags

renderFlags :: RegexFlags -> String
renderFlags flags =
  (if flags.global then "g" else "") ++
  (if flags.ignoreCase then "i" else "") ++
  (if flags.multiline then "m" else "") ++
  (if flags.sticky then "y" else "") ++
  (if flags.unicode then "u" else "")

parseFlags :: String -> RegexFlags
parseFlags s =
  { global: indexOf "g" s >= 0
  , ignoreCase: indexOf "i" s >= 0
  , multiline: indexOf "m" s >= 0
  , sticky: indexOf "y" s >= 0
  , unicode: indexOf "u" s >= 0
  }

foreign import test
  """
  function test(r) {
    return function(s) {
      return r.test(s);
    };
  }
  """ :: Regex -> String -> Boolean

foreign import _match
  """
  function _match(r, s, Just, Nothing) {
    var m = s.match(r);
    return m == null ? Nothing : Just(m);
  }
  """ :: forall r. Fn4 Regex String ([String] -> r) r r

match :: Regex -> String -> Maybe [String]
match r s = runFn4 _match r s Just Nothing

foreign import replace
  """
  function replace(r) {
    return function(s1) {
      return function(s2) {
        return s2.replace(r, s1);
      };
    };
  }
  """ :: Regex -> String -> String -> String

foreign import replace'
  """
  function replace$prime(r) {
    return function(f) {
      return function(s2) {
        return s2.replace(r, function(match) {
          return f(match)(Array.prototype.splice.call(arguments, 1, arguments.length - 3));
        });
      };
    };
  }
  """ :: Regex -> (String -> [String] -> String) -> String -> String

foreign import search
  """
  function search(r) {
    return function(s) {
      return s.search(r);
    };
  }
  """ :: Regex -> String -> Number

foreign import split
  """
  function split(r) {
    return function(s) {
      return s.split(r);
    };
  }
  """ :: Regex -> String -> [String]

module Data.String.Regex (
  Regex(..),
  RegexFlags(..),
  regex,
  source,
  flags,
  renderFlags,
  parseFlags,
  test,
  match,
  replace,
  replace',
  search,
  split
  ) where

import Data.Function
import Data.Maybe
import Data.String (indexOf)

foreign import data Regex :: *

foreign import showRegex'
  """
  function showRegex$prime(r) {
    return '' + r;
  }
  """ :: Regex -> String

instance showRegex :: Show Regex where
  show = showRegex'

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

foreign import regex'
  """
  function regex$prime(s1) {
    return function(s2) {
      return new RegExp(s1, s2);
    };
  }
  """ :: String -> String -> Regex

regex :: String -> RegexFlags -> Regex
regex source flags = regex' source $ renderFlags flags

foreign import source
  """
  function source(r) {
    return r.source;
  }
  """ :: Regex -> String

foreign import flags
  """
  function flags(r) {
    return {
      multiline: r.multiline,
      ignoreCase: r.ignoreCase,
      global: r.global,
      sticky: !!r.sticky,
      unicode: !!r.unicode
    };
  }
  """ :: Regex -> RegexFlags

renderFlags :: RegexFlags -> String
renderFlags flags =
  (if flags.global then "g" else "") ++
  (if flags.ignoreCase then "i" else "") ++
  (if flags.multiline then "m" else "") ++
  (if flags.sticky then "y" else "") ++
  (if flags.unicode then "u" else "")

parseFlags :: String -> RegexFlags
parseFlags s =
  { global: indexOf "g" s >= 0
  , ignoreCase: indexOf "i" s >= 0
  , multiline: indexOf "m" s >= 0
  , sticky: indexOf "y" s >= 0
  , unicode: indexOf "u" s >= 0
  }

foreign import test
  """
  function test(r) {
    return function(s) {
      return r.test(s);
    };
  }
  """ :: Regex -> String -> Boolean

foreign import _match
  """
  function _match(r, s, Just, Nothing) {
    var m = s.match(r);
    return m == null ? Nothing : Just(m);
  }
  """ :: forall r. Fn4 Regex String ([String] -> r) r r

match :: Regex -> String -> Maybe [String]
match r s = runFn4 _match r s Just Nothing

foreign import replace
  """
  function replace(r) {
    return function(s1) {
      return function(s2) {
        return s2.replace(r, s1);
      };
    };
  }
  """ :: Regex -> String -> String -> String

foreign import replace'
  """
  function replace$prime(r) {
    return function(f) {
      return function(s2) {
        return s2.replace(r, function(match) {
          return f(match)(Array.prototype.splice.call(arguments, 1, arguments.length - 3));
        });
      };
    };
  }
  """ :: Regex -> (String -> [String] -> String) -> String -> String

foreign import search
  """
  function search(r) {
    return function(s) {
      return s.search(r);
    };
  }
  """ :: Regex -> String -> Number

foreign import split
  """
  function split(r) {
    return function(s) {
      return s.split(r);
    };
  }
  """ :: Regex -> String -> [String]