duet-0.0.1: src/Duet/Parser.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
module Duet.Parser where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.List
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Duet.Printer
import Duet.Tokenizer
import Duet.Types
import Text.Parsec hiding (satisfy, anyToken)
parseFile :: (MonadIO m, MonadThrow m) => FilePath -> m [Decl UnkindedType Identifier Location]
parseFile fp = do
t <- liftIO (T.readFile fp)
parseText fp t
parseText :: MonadThrow m => SourceName -> Text -> m [Decl UnkindedType Identifier Location]
parseText fp inp =
case parse tokensTokenizer fp (inp) of
Left e -> throwM (TokenizerError e)
Right tokens' ->
case runParser tokensParser 0 fp tokens' of
Left e -> throwM (ParserError e)
Right ast -> pure ast
parseTextWith
:: (Num u, MonadThrow m)
=> Parsec [(Token, Location)] u a -> SourceName -> Text -> m a
parseTextWith p fp inp =
case parse tokensTokenizer fp (inp) of
Left e -> throwM (TokenizerError e)
Right tokens' ->
case runParser p 0 fp tokens' of
Left e -> throwM (ParserError e)
Right ast -> pure ast
parseType' :: Num u => SourceName -> Parsec [(Token, Location)] u b -> Text -> Either ParseError b
parseType' fp p inp =
case parse tokensTokenizer fp (inp) of
Left e -> Left e
Right tokens' ->
case runParser p 0 fp tokens' of
Left e -> Left e
Right ast -> Right ast
tokensParser :: TokenParser [Decl UnkindedType Identifier Location]
tokensParser = moduleParser <* endOfTokens
moduleParser :: TokenParser [Decl UnkindedType Identifier Location]
moduleParser =
many
(varfundeclExplicit <|> fmap (uncurry DataDecl) datadecl <|>
fmap (uncurry ClassDecl) classdecl <|>
fmap (uncurry InstanceDecl) instancedecl)
classdecl :: TokenParser (Location, Class UnkindedType Identifier Location)
classdecl =
go <?> "class declaration (e.g. class Show a where show a :: a -> String)"
where
go = do
u <- getState
loc <- equalToken ClassToken
setState (locationStartColumn loc)
(c, _) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing) <?>
"new class name e.g. Show"
vars <- many1 kindableTypeVariable
mwhere <-
fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl
methods <-
if mwhere
then do
(_, identLoc) <-
lookAhead
(consumeToken
(\case
Variable i -> Just i
_ -> Nothing)) <?>
"class methods e.g. foo :: a -> Int"
(many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl
else (pure [])
setState u
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
pure
( loc
, Class
{ className = Identifier (T.unpack c)
, classTypeVariables = vars
, classSuperclasses = []
, classInstances = []
, classMethods = M.fromList methods
})
where
endOfDecl =
(pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
methodParser startCol = go' <?> "method signature e.g. foo :: a -> Y"
where
go' = do
u <- getState
(v, p) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
when
(locationStartColumn p /= startCol)
(unexpected
("method name at column " ++
show (locationStartColumn p) ++
", it should start at column " ++
show startCol ++ " to match the others"))
setState startCol
_ <- equalToken Colons <?> "‘::’ for method signature"
scheme <- parseScheme <?> "method type signature e.g. foo :: Int"
setState u
pure (Identifier (T.unpack v), scheme)
kindableTypeVariable :: Stream s m (Token, Location) => ParsecT s Int m (TypeVariable Identifier)
kindableTypeVariable = (unkinded <|> kinded) <?> "type variable (e.g. ‘a’, ‘f’, etc.)"
where
kinded =
kparens
(do t <- unkinded
_ <- equalToken Colons
k <- kindParser
pure (TypeVariable (typeVariableIdentifier t) k))
where
kparens :: TokenParser a -> TokenParser a
kparens p = g <?> "parens e.g. (x)"
where
g = do
_ <- equalToken OpenParen
e <-
p <?> "type with kind inside parentheses e.g. (t :: Type)"
_ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
pure e
unkinded = do
(v, _) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing) <?>
"variable name"
pure (TypeVariable (Identifier (T.unpack v)) StarKind)
parseScheme
:: Stream s m (Token, Location)
=> ParsecT s Int m (Scheme UnkindedType Identifier UnkindedType)
parseScheme = do
explicit <-
fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False
if explicit
then quantified
else do
ty@(Qualified _ qt) <- parseQualified
pure (Forall (nub (collectTypeVariables qt)) ty)
where
quantified = do
_ <- equalToken ForallToken
vars <- many1 kindableTypeVariable <?> "type variables"
_ <- equalToken Period
ty <- parseQualified
pure (Forall vars ty)
parseSchemePredicate
:: Stream s m (Token, Location)
=> ParsecT s Int m (Scheme UnkindedType Identifier (Predicate UnkindedType))
parseSchemePredicate = do
explicit <-
fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False
if explicit
then quantified
else do
ty@(Qualified _ (IsIn _ qt)) <- parseQualifiedPredicate
pure (Forall (nub (concatMap collectTypeVariables qt)) ty)
where
quantified = do
_ <- equalToken ForallToken
vars <- many1 kindableTypeVariable <?> "type variables"
_ <- equalToken Period
ty <- parseQualifiedPredicate
pure (Forall vars ty)
parseQualified
:: Stream s m (Token, Location)
=> ParsecT s Int m (Qualified UnkindedType Identifier (UnkindedType Identifier))
parseQualified = do
ty <- parsedTypeLike
(case ty of
ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toType x
where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts
_ -> do
t <- toType ty
pure (Qualified [] t)) <?>
"qualified type e.g. Show x => x"
parseQualifiedPredicate
:: Stream s m (Token, Location)
=> ParsecT s Int m (Qualified UnkindedType Identifier (Predicate UnkindedType Identifier))
parseQualifiedPredicate = do
ty <- parsedTypeLike
(case ty of
ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toPredicateUnkinded x
where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts
_ -> do
t <- toPredicateUnkinded ty
pure (Qualified [] t)) <?>
"qualified type e.g. Show x => x"
collectTypeVariables :: UnkindedType i -> [TypeVariable i]
collectTypeVariables =
\case
UnkindedTypeConstructor {} -> []
UnkindedTypeVariable i -> [TypeVariable i StarKind]
UnkindedTypeApp f x -> collectTypeVariables f ++ collectTypeVariables x
instancedecl :: TokenParser (Location, Instance UnkindedType Identifier Location)
instancedecl =
go <?> "instance declaration (e.g. instance Show Int where show = ...)"
where
go = do
u <- getState
loc <- equalToken InstanceToken
setState (locationStartColumn loc)
predicate@(Forall _ (Qualified _ (IsIn (Identifier c) _))) <-
parseSchemePredicate
mwhere <-
fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl
methods <-
if mwhere
then do
(_, identLoc) <-
lookAhead
(consumeToken
(\case
Variable i -> Just i
_ -> Nothing)) <?>
"instance methods e.g. foo :: a -> Int"
(many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl
else (pure [])
setState u
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
let dictName = "$dict" ++ c
pure
( loc
, Instance
{ instancePredicate = predicate
, instanceDictionary =
Dictionary (Identifier dictName) (M.fromList methods)
})
where
endOfDecl =
(pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
methodParser startCol =
go' <?> "method implementation e.g. foo = \\x -> f x"
where
go' = do
u <- getState
(v, p) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
when
(locationStartColumn p /= startCol)
(unexpected
("method name at column " ++
show (locationStartColumn p) ++
", it should start at column " ++
show startCol ++ " to match the others"))
setState startCol
_ <- equalToken Equals <?> "‘=’ for method declaration e.g. x = 1"
e <- expParser
setState u
pure (Identifier (T.unpack v), (p, makeAlt (expressionLabel e) e))
parseType :: Stream s m (Token, Location) => ParsecT s Int m (UnkindedType Identifier)
parseType = do
x <- parsedTypeLike
toType x
toPredicateUnkinded :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate UnkindedType i)
toPredicateUnkinded = toPredicate >=> go
where go (IsIn c tys) = IsIn c <$> mapM toType tys
toType :: Stream s m t => ParsedType i -> ParsecT s u m (UnkindedType i)
toType = go
where
go =
\case
ParsedTypeConstructor i -> pure (UnkindedTypeConstructor i)
ParsedTypeVariable i -> pure (UnkindedTypeVariable i)
ParsedTypeApp t1 t2 -> UnkindedTypeApp <$> go t1 <*> go t2
ParsedQualified {} -> unexpected "qualification context"
ParsedTuple {} -> unexpected "tuple"
datadecl :: TokenParser (Location, DataType UnkindedType Identifier)
datadecl = go <?> "data declaration (e.g. data Maybe a = Just a | Nothing)"
where
go = do
loc <- equalToken Data
(v, _) <-
consumeToken
(\case
Constructor i -> Just i
_ -> Nothing) <?>
"new type name (e.g. Foo)"
vs <- many kindableTypeVariable
_ <- equalToken Equals
cs <- sepBy1 consp (equalToken Bar)
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
pure (loc, DataType (Identifier (T.unpack v)) vs cs)
kindParser :: Stream s m (Token, Location) => ParsecT s Int m Kind
kindParser = infix'
where
infix' = do
left <- star
tok <-
fmap Just (operator <?> ("arrow " ++ curlyQuotes "->")) <|> pure Nothing
case tok of
Just (RightArrow, _) -> do
right <-
kindParser <?>
("right-hand side of function arrow " ++ curlyQuotes "->")
pure (FunctionKind left right)
_ -> pure left
where
operator =
satisfyToken
(\case
RightArrow {} -> True
_ -> False)
star = do
(c, _) <-
consumeToken
(\case
Constructor c
| c == "Type" -> Just StarKind
_ -> Nothing)
pure c
consp :: TokenParser (DataTypeConstructor UnkindedType Identifier)
consp = do c <- consParser
slots <- many slot
pure (DataTypeConstructor c slots)
where consParser = go <?> "value constructor (e.g. Just)"
where
go = do
(c, _) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing)
pure
(Identifier (T.unpack c))
slot :: TokenParser (UnkindedType Identifier)
slot = consParser <|> variableParser <|> parens parseType
where
variableParser = go <?> "type variable (e.g. ‘a’, ‘s’, etc.)"
where
go = do
(v, _) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
pure (UnkindedTypeVariable (Identifier (T.unpack v)))
consParser = go <?> "type constructor (e.g. Maybe)"
where
go = do
(c, _) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing)
pure (UnkindedTypeConstructor (Identifier (T.unpack c)))
data ParsedType i
= ParsedTypeConstructor i
| ParsedTypeVariable i
| ParsedTypeApp (ParsedType i) (ParsedType i)
| ParsedQualified [Predicate ParsedType i] (ParsedType i)
| ParsedTuple [ParsedType i]
deriving (Show)
parsedTypeLike :: TokenParser (ParsedType Identifier)
parsedTypeLike = infix' <|> app <|> unambiguous
where
infix' = do
left <- (app <|> unambiguous) <?> "left-hand side of function arrow"
tok <-
fmap Just (operator <?> ("function arrow " ++ curlyQuotes "->")) <|>
fmap Just (operator2 <?> ("constraint arrow " ++ curlyQuotes "=>")) <|>
pure Nothing
case tok of
Just (RightArrow, _) -> do
right <-
parsedTypeLike <?>
("right-hand side of function arrow " ++ curlyQuotes "->")
pure
(ParsedTypeApp
(ParsedTypeApp (ParsedTypeConstructor (Identifier "(->)")) left)
right)
Just (Imply, _) -> do
left' <- parsedTypeToPredicates left <?> "constraints e.g. Show a or (Read a, Show a)"
right <-
parsedTypeLike <?>
("right-hand side of constraints " ++ curlyQuotes "=>")
pure (ParsedQualified left' right)
_ -> pure left
where
operator =
satisfyToken
(\case
RightArrow {} -> True
_ -> False)
operator2 =
satisfyToken
(\case
Imply {} -> True
_ -> False)
app = do
f <- unambiguous
args <- many unambiguous
pure (foldl' ParsedTypeApp f args)
unambiguous =
atomicType <|>
parensTy
(do xs <- sepBy1 parsedTypeLike (equalToken Comma)
case xs of
[x] -> pure x
_ -> pure (ParsedTuple xs))
atomicType = consParse <|> varParse
consParse = do
(v, _) <-
consumeToken
(\case
Constructor i -> Just i
_ -> Nothing) <?>
"type constructor (e.g. Int, Maybe)"
pure (ParsedTypeConstructor (Identifier (T.unpack v)))
varParse = do
(v, _) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing) <?>
"type variable (e.g. a, f)"
pure (ParsedTypeVariable (Identifier (T.unpack v)))
parensTy p = go <?> "parentheses e.g. (T a)"
where
go = do
_ <- equalToken OpenParen
e <- p <?> "type inside parentheses e.g. (Maybe a)"
_ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
pure e
parsedTypeToPredicates :: Stream s m t => ParsedType i -> ParsecT s u m [Predicate ParsedType i]
parsedTypeToPredicates =
\case
ParsedTuple xs -> mapM toPredicate xs
x -> fmap return (toPredicate x)
toPredicate :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate ParsedType i)
toPredicate t =
case targs t of
(ParsedTypeConstructor i, vars@ (_:_)) -> do
pure (IsIn i vars)
_ -> unexpected "non-class constraint"
toVar :: Stream s m t1 => ParsedType t -> ParsecT s u m (ParsedType t)
toVar =
\case
v@ParsedTypeVariable {} -> pure v
_ -> unexpected "non-type-variable"
targs :: ParsedType t -> (ParsedType t, [ParsedType t])
targs e = go e []
where
go (ParsedTypeApp f x) args = go f (x : args)
go f args = (f, args)
varfundecl :: TokenParser (ImplicitlyTypedBinding UnkindedType Identifier Location)
varfundecl = go <?> "variable declaration (e.g. x = 1, f = \\x -> x * x)"
where
go = do
(v, loc) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing) <?>
"variable name"
_ <- equalToken Equals <?> "‘=’ for variable declaration e.g. x = 1"
e <- expParser
_ <- (pure () <* satisfyToken (==NonIndentedNewline)) <|> endOfTokens
pure (ImplicitlyTypedBinding loc (Identifier (T.unpack v), loc) [makeAlt loc e])
varfundeclExplicit :: TokenParser (Decl UnkindedType Identifier Location)
varfundeclExplicit =
go <?> "explicitly typed variable declaration (e.g. x :: Int and x = 1)"
where
go = do
(v0, loc) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing) <?>
"variable name"
(tok, _) <- anyToken <?> curlyQuotes "::" ++ " or " ++ curlyQuotes "="
case tok of
Colons -> do
scheme <- parseScheme <?> "type signature e.g. foo :: Int"
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
(v, _) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing) <?>
"variable name"
when
(v /= v0)
(unexpected "variable binding name different to the type signature")
_ <- equalToken Equals <?> "‘=’ for variable declaration e.g. x = 1"
e <- expParser
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
pure
(BindDecl
loc
(ExplicitBinding
(ExplicitlyTypedBinding loc
(Identifier (T.unpack v), loc)
scheme
[makeAlt loc e])))
Equals -> do
e <- expParser
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
pure
(BindDecl
loc
(ImplicitBinding
(ImplicitlyTypedBinding
loc
(Identifier (T.unpack v0), loc)
[makeAlt loc e])))
t -> unexpected (tokenStr t)
makeAlt :: l -> Expression t i l -> Alternative t i l
makeAlt loc e =
case e of
LambdaExpression _ alt -> alt
_ -> Alternative loc [] e
case' :: TokenParser (Expression UnkindedType Identifier Location)
case' = do
u <- getState
loc <- equalToken Case
setState (locationStartColumn loc)
e <- expParser <?> "expression to do case analysis e.g. case e of ..."
_ <- equalToken Of
p <- lookAhead altPat <?> "case pattern"
alts <- many (altParser (Just e) (locationStartColumn (patternLabel p)))
setState u
pure (CaseExpression loc e alts)
altsParser
:: Stream s m (Token, Location)
=> ParsecT s Int m [(CaseAlt UnkindedType Identifier Location)]
altsParser = many (altParser Nothing 1)
altParser
:: Maybe (Expression UnkindedType Identifier Location)
-> Int
-> TokenParser (CaseAlt UnkindedType Identifier Location)
altParser e' startCol =
(do u <- getState
p <- altPat
when
(locationStartColumn (patternLabel p) /= startCol)
(unexpected
("pattern at column " ++
show (locationStartColumn (patternLabel p)) ++
", it should start at column " ++
show startCol ++ " to match the others"))
setState startCol
_ <- equalToken RightArrow
e <- expParser
setState u
pure (CaseAlt (Location 0 0 0 0) p e)) <?>
("case alternative" ++
(case e' of
Just eeee ->
" e.g.\n\ncase " ++
printExpression defaultPrint eeee ++
" of\n Just bar -> bar"
Nothing -> ""))
altPat :: TokenParser (Pattern UnkindedType Identifier Location)
altPat = bang <|> varp <|> intliteral <|> consParser <|> stringlit
where
bang =
(BangPattern <$>
(consumeToken
(\case
Bang -> Just Bang
_ -> Nothing) *>
patInner)) <?> "bang pattern"
patInner = parenpat <|> varp <|> intliteral <|> unaryConstructor
parenpat = go
where
go = do
_ <- equalToken OpenParen
e <- varp <|> altPat
_ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
pure e
intliteral = go <?> "integer (e.g. 42, 123)"
where
go = do
(c, loc) <-
consumeToken
(\case
Integer c -> Just c
_ -> Nothing)
pure (LiteralPattern loc (IntegerLiteral c))
stringlit = go <?> "string (e.g. 42, 123)"
where
go = do
(c, loc) <-
consumeToken
(\case
String c -> Just c
_ -> Nothing)
pure (LiteralPattern loc (StringLiteral (T.unpack c)))
varp = go <?> "variable pattern (e.g. x)"
where
go = do
(v, loc) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
pure
(if T.isPrefixOf "_" v
then WildcardPattern loc (T.unpack v)
else VariablePattern loc (Identifier (T.unpack v)))
unaryConstructor = go <?> "unary constructor (e.g. Nothing)"
where
go = do
(c, loc) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing)
pure (ConstructorPattern loc (Identifier (T.unpack c)) [])
consParser = go <?> "constructor pattern (e.g. Just x)"
where
go = do
(c, loc) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing)
args <- many patInner
pure (ConstructorPattern loc (Identifier (T.unpack c)) args)
expParser :: TokenParser (Expression UnkindedType Identifier Location)
expParser = case' <|> lambda <|> ifParser <|> infix' <|> app <|> atomic
where
app = do
left <- funcOp <?> "function expression"
right <- many unambiguous <?> "function arguments"
case right of
[] -> pure left
_ -> pure (foldl (ApplicationExpression (Location 0 0 0 0)) left right)
infix' =
(do left <- (app <|> unambiguous) <?> "left-hand side of operator"
tok <- fmap Just (operator <?> "infix operator") <|> pure Nothing
case tok of
Just (Operator t, _) -> do
right <-
(app <|> unambiguous) <?>
("right-hand side of " ++
curlyQuotes (T.unpack t) ++ " operator")
badop <- fmap Just (lookAhead operator) <|> pure Nothing
let infixexp =
InfixExpression
(Location 0 0 0 0)
left
(let i = ((T.unpack t))
in (i, VariableExpression (Location 0 0 0 0) (Identifier i)))
right
maybe
(return ())
(\op ->
unexpected
(concat
[ tokenString op ++
". When more than one operator is used\n"
, "in the same expression, use parentheses, like this:\n"
, "(" ++
printExpression defaultPrint infixexp ++
") " ++
(case op of
(Operator i, _) -> T.unpack i ++ " ..."
_ -> "* ...") ++
"\n"
, "Or like this:\n"
, printExpressionAppArg defaultPrint left ++
" " ++
T.unpack t ++
" (" ++
printExpressionAppArg defaultPrint right ++
" " ++
case op of
(Operator i, _) -> T.unpack i ++ " ...)"
_ -> "* ...)"
]))
badop
pure infixexp
_ -> pure left) <?>
"infix expression (e.g. x * y)"
where
operator =
satisfyToken
(\case
Operator {} -> True
_ -> False)
funcOp = varParser <|> constructorParser <|> parensExpr
unambiguous = parensExpr <|> atomic
parensExpr = parens expParser
operatorParser
:: Stream s m (Token, Location)
=> ParsecT s Int m (String, Expression t Identifier Location)
operatorParser = do
tok <-
satisfyToken
(\case
Operator {} -> True
_ -> False)
pure
(case tok of
(Operator t, _) ->
let i = (T.unpack t)
in (i, VariableExpression (Location 0 0 0 0) (Identifier i))
_ -> error "should be operator...")
lambda :: TokenParser (Expression UnkindedType Identifier Location)
lambda = do
loc <- equalToken Backslash <?> "lambda expression (e.g. \\x -> x)"
args <- many1 funcParam <?> "lambda parameters"
_ <- equalToken RightArrow
e <- expParser
pure (LambdaExpression loc (Alternative loc args e))
funcParams :: TokenParser [Pattern UnkindedType Identifier Location]
funcParams = many1 funcParam
funcParam :: TokenParser (Pattern UnkindedType Identifier Location)
funcParam = go <?> "function parameter (e.g. ‘x’, ‘limit’, etc.)"
where
go = do
(v, loc) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
pure (VariablePattern loc (Identifier (T.unpack v)))
atomic :: TokenParser (Expression UnkindedType Identifier Location)
atomic =
varParser <|> charParser <|> stringParser <|> integerParser <|> decimalParser <|>
constructorParser
where
charParser = go <?> "character (e.g. 'a')"
where
go = do
(c, loc) <-
consumeToken
(\case
Character c -> Just c
_ -> Nothing)
pure (LiteralExpression loc (CharacterLiteral c))
stringParser = go <?> "string (e.g. \"a\")"
where
go = do
(c, loc) <-
consumeToken
(\case
String c -> Just c
_ -> Nothing)
pure (LiteralExpression loc (StringLiteral (T.unpack c)))
integerParser = go <?> "integer (e.g. 42, 123)"
where
go = do
(c, loc) <-
consumeToken
(\case
Integer c -> Just c
_ -> Nothing)
pure (LiteralExpression loc (IntegerLiteral c))
decimalParser = go <?> "decimal (e.g. 42, 123)"
where
go = do
(c, loc) <-
consumeToken
(\case
Decimal c -> Just c
_ -> Nothing)
pure (LiteralExpression loc (RationalLiteral (realToFrac c)))
constructorParser :: TokenParser (Expression UnkindedType Identifier Location)
constructorParser = go <?> "constructor (e.g. Just)"
where
go = do
(c, loc) <-
consumeToken
(\case
Constructor c -> Just c
_ -> Nothing)
pure
(ConstructorExpression loc (Identifier (T.unpack c)))
parens :: TokenParser a -> TokenParser a
parens p = go <?> "parens e.g. (x)"
where go = do
_ <- equalToken OpenParen
e <- p <?> "expression inside parentheses e.g. (foo)"
_ <- equalToken CloseParen<?> "closing parenthesis ‘)’"
pure e
varParser :: TokenParser (Expression UnkindedType Identifier Location)
varParser = go <?> "variable (e.g. ‘foo’, ‘id’, etc.)"
where
go = do
(v, loc) <-
consumeToken
(\case
Variable i -> Just i
_ -> Nothing)
pure (if T.isPrefixOf "_" v
then ConstantExpression loc (Identifier (T.unpack v))
else VariableExpression loc (Identifier (T.unpack v)))
ifParser :: TokenParser (Expression UnkindedType Identifier Location)
ifParser = go <?> "if expression (e.g. ‘if p then x else y’)"
where
go = do
loc <- equalToken If
p <- expParser <?> "condition expresion of if-expression"
_ <- equalToken Then <?> "‘then’ keyword for if-expression"
e1 <- expParser <?> "‘then’ clause of if-expression"
_ <- equalToken Else <?> "‘else’ keyword for if-expression"
e2 <- expParser <?> "‘else’ clause of if-expression"
pure
(IfExpression
loc
{ locationEndLine = locationEndLine (expressionLocation loc e2)
, locationEndColumn = locationEndColumn (expressionLocation loc e2)
}
p
e1
e2)
expressionLocation nil e = foldr const nil e