Allow multiline expressions
This commit is contained in:
James Eversole
parent
eeaf9e0289
commit
ec0a6b7b16
78
lib/base.tri
78
lib/base.tri
@ -17,25 +17,77 @@ yD = yi iE
|
||||
id = (\a : a)
|
||||
triage = (\a b c : t (t a b) c)
|
||||
pair = t
|
||||
matchBool = (\ot of : triage of (\_ : ot) (\_ _ : ot))
|
||||
matchList = (\oe oc : triage oe _ oc)
|
||||
matchPair = (\op : triage _ _ op)
|
||||
|
||||
matchBool = (\ot of : triage
|
||||
of
|
||||
(\_ : ot)
|
||||
(\_ _ : ot)
|
||||
)
|
||||
|
||||
matchList = (\oe oc : triage
|
||||
oe
|
||||
_
|
||||
oc
|
||||
)
|
||||
|
||||
matchPair = (\op : triage
|
||||
_
|
||||
_
|
||||
op
|
||||
)
|
||||
|
||||
not = matchBool false true
|
||||
and = matchBool id (\z : false)
|
||||
if = (\cond then else : t (t else (t t then)) t cond)
|
||||
test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
|
||||
|
||||
emptyList = matchList true (\y z : false)
|
||||
head = matchList t (\hd tl : hd)
|
||||
tail = matchList t (\hd tl : tl)
|
||||
lconcat = y (\self : matchList (\k : k) (\h r k : pair h (self r k)))
|
||||
lAnd = triage (\x : false) (\_ x : x) (\_ _ x : x)
|
||||
lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true)
|
||||
hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f)))
|
||||
|
||||
lconcat = y (\self : matchList
|
||||
(\k : k)
|
||||
(\h r k : pair h (self r k)))
|
||||
|
||||
lAnd = (triage
|
||||
(\x : false)
|
||||
(\_ x : x)
|
||||
(\_ _ x : x)
|
||||
)
|
||||
|
||||
lOr = (triage
|
||||
(\x : x)
|
||||
(\_ _ : true)
|
||||
(\_ _ x : true)
|
||||
)
|
||||
|
||||
hmap = y (\self :
|
||||
matchList
|
||||
(\f : t)
|
||||
(\hd tl f : pair
|
||||
(f hd)
|
||||
(self tl f)))
|
||||
map = (\f l : hmap l f)
|
||||
equal = y (\self : triage (triage true (\z : false) (\y z : false)) (\ax : triage false (self ax) (\y z : false)) (\ax ay : triage false (\z : false) (\bx by : lAnd (self ax bx) (self ay by))))
|
||||
|
||||
equal = y (\self : triage
|
||||
(triage
|
||||
true
|
||||
(\z : false)
|
||||
(\y z : false))
|
||||
(\ax : triage
|
||||
false
|
||||
(self ax)
|
||||
(\y z : false))
|
||||
(\ax ay : triage
|
||||
false
|
||||
(\z : false)
|
||||
(\bx by : lAnd (self ax bx) (self ay by))))
|
||||
|
||||
hfilter = y (\self : matchList (\f : t) (\hd tl f : matchBool (t hd) i (f hd) (self tl f)))
|
||||
filter = (\f l : hfilter l f)
|
||||
hfoldl = y (\self f l x : matchList (\acc : acc) (\hd tl acc : self f tl (f acc hd)) l x)
|
||||
foldl = (\f x l : hfoldl f l x)
|
||||
hfoldr = y (\self x f l : matchList x (\hd tl : f (self x f tl) hd) l)
|
||||
foldr = (\f x l : hfoldr x f l)
|
||||
filter = (\f l : hfilter l f)
|
||||
|
||||
hfoldl = y (\self f l x : matchList (\acc : acc) (\hd tl acc : self f tl (f acc hd)) l x)
|
||||
foldl = (\f x l : hfoldl f l x)
|
||||
|
||||
hfoldr = y (\self x f l : matchList x (\hd tl : f (self x f tl) hd) l)
|
||||
foldr = (\f x l : hfoldr x f l)
|
||||
|
||||
29
src/Eval.hs
29
src/Eval.hs
@ -13,22 +13,23 @@ evalSingle env term
|
||||
| SFunc name [] body <- term =
|
||||
let res = evalAST env body
|
||||
in Map.insert "__result" res (Map.insert name res env)
|
||||
| SApp func arg <- term = Map.insert "__result"
|
||||
(apply (evalAST env func) (evalAST env arg)) env
|
||||
| SVar name <- term = case Map.lookup name env of
|
||||
Just v -> Map.insert "__result" v env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
| otherwise = Map.insert "__result" (evalAST env term) env
|
||||
| SApp func arg <- term =
|
||||
let res = apply (evalAST env func) (evalAST env arg)
|
||||
in Map.insert "__result" res env
|
||||
| SVar name <- term =
|
||||
case Map.lookup name env of
|
||||
Just v -> Map.insert "__result" v env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
| otherwise =
|
||||
Map.insert "__result" (evalAST env term) env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
|
||||
where
|
||||
evalTricu' :: Env -> [TricuAST] -> Env
|
||||
evalTricu' env [] = env
|
||||
evalTricu' env [s] =
|
||||
let updatedEnv = evalSingle env s
|
||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||
evalTricu' env (x:xs) = evalTricu (evalSingle env x) xs
|
||||
evalTricu env [] = env
|
||||
evalTricu env [x] =
|
||||
let updatedEnv = evalSingle env x
|
||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||
evalTricu env (x:xs) =
|
||||
evalTricu (evalSingle env x) xs
|
||||
|
||||
evalAST :: Env -> TricuAST -> T
|
||||
evalAST env term
|
||||
|
||||
@ -61,7 +61,10 @@ lnewline :: Lexer LToken
|
||||
lnewline = char '\n' *> pure LNewline
|
||||
|
||||
sc :: Lexer ()
|
||||
sc = space space1 (skipLineComment "--") (skipBlockComment "|-" "-|")
|
||||
sc = space
|
||||
(void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t'))
|
||||
(skipLineComment "--")
|
||||
(skipBlockComment "|-" "-|")
|
||||
|
||||
tricuLexer :: Lexer [LToken]
|
||||
tricuLexer = do
|
||||
@ -75,7 +78,8 @@ tricuLexer = do
|
||||
pure tokens
|
||||
where
|
||||
tricuLexer' =
|
||||
[ try identifier
|
||||
[ try lnewline
|
||||
, try identifier
|
||||
, try keywordT
|
||||
, try integerLiteral
|
||||
, try stringLiteral
|
||||
|
||||
@ -81,4 +81,7 @@ main = do
|
||||
putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value
|
||||
|
||||
runTricu :: String -> T
|
||||
runTricu = result . evalTricu Map.empty . parseTricu
|
||||
runTricu input =
|
||||
let asts = parseTricu input
|
||||
finalEnv = evalTricu Map.empty asts
|
||||
in result finalEnv
|
||||
|
||||
466
src/Parser.hs
466
src/Parser.hs
@ -1,281 +1,299 @@
|
||||
module Parser where
|
||||
|
||||
import Lexer
|
||||
import Research hiding (toList)
|
||||
import Research
|
||||
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.State
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
type Parser = Parsec Void [LToken]
|
||||
type AltParser = Parsec Void String
|
||||
data PState = PState
|
||||
{ depth :: Int
|
||||
} deriving (Show)
|
||||
|
||||
type ParserM = StateT PState (Parsec Void [LToken])
|
||||
|
||||
satisfyM :: (LToken -> Bool) -> ParserM LToken
|
||||
satisfyM f = do
|
||||
token <- lift (satisfy f)
|
||||
modify' (updateDepth token)
|
||||
return token
|
||||
|
||||
updateDepth :: LToken -> PState -> PState
|
||||
updateDepth LOpenParen st = st { depth = depth st + 1 }
|
||||
updateDepth LCloseParen st = st { depth = max 0 (depth st - 1) }
|
||||
updateDepth _ st = st
|
||||
|
||||
topLevelNewline :: ParserM ()
|
||||
topLevelNewline = do
|
||||
st <- get
|
||||
if depth st == 0
|
||||
then void (satisfyM (== LNewline))
|
||||
else fail "Top-level exit in paren context"
|
||||
|
||||
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
|
||||
parseProgram tokens =
|
||||
runParser (evalStateT parseProgramM (PState 0)) "" tokens
|
||||
|
||||
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
|
||||
parseSingleExpr tokens =
|
||||
runParser (evalStateT (scnParserM *> parseExpressionM <* eofM) (PState 0)) "" tokens
|
||||
|
||||
parseTricu :: String -> [TricuAST]
|
||||
parseTricu input
|
||||
| null tokens = []
|
||||
| otherwise = map parseSingle tokens
|
||||
where
|
||||
tokens
|
||||
| null (lexTricu input) = []
|
||||
| otherwise = lines input
|
||||
parseTricu input =
|
||||
case lexTricu input of
|
||||
[] -> []
|
||||
toks ->
|
||||
case parseProgram toks of
|
||||
Left err -> error (handleParseError err)
|
||||
Right asts -> asts
|
||||
|
||||
parseSingle :: String -> TricuAST
|
||||
parseSingle input
|
||||
| null tokens = SEmpty
|
||||
| Left err <- parsed = error $ handleParseError err
|
||||
| Right ast <- parsed = ast
|
||||
where
|
||||
tokens = lexTricu input
|
||||
parsed = runParser parseExpression "" tokens
|
||||
parseSingle input =
|
||||
case lexTricu input of
|
||||
[] -> SEmpty
|
||||
toks ->
|
||||
case parseSingleExpr toks of
|
||||
Left err -> error (handleParseError err)
|
||||
Right ast -> ast
|
||||
|
||||
parseExpression :: Parser TricuAST
|
||||
parseExpression = choice
|
||||
[ try parseFunction
|
||||
, try parseLambda
|
||||
, try parseLambdaExpression
|
||||
, try parseListLiteral
|
||||
, try parseApplication
|
||||
, try parseTreeTerm
|
||||
, parseLiteral
|
||||
parseProgramM :: ParserM [TricuAST]
|
||||
parseProgramM = do
|
||||
skipMany topLevelNewline
|
||||
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
||||
skipMany topLevelNewline
|
||||
return exprs
|
||||
|
||||
parseOneExpression :: ParserM TricuAST
|
||||
parseOneExpression = scnParserM *> parseExpressionM
|
||||
|
||||
scnParserM :: ParserM ()
|
||||
scnParserM = skipMany $ do
|
||||
t <- lookAhead anySingle
|
||||
st <- get
|
||||
if depth st > 0 && isNewline t
|
||||
then void (satisfyM isNewline)
|
||||
else
|
||||
fail "In paren context or no space token" <|> empty
|
||||
|
||||
eofM :: ParserM ()
|
||||
eofM = lift eof
|
||||
|
||||
parseExpressionM :: ParserM TricuAST
|
||||
parseExpressionM = choice
|
||||
[ try parseFunctionM
|
||||
, try parseLambdaM
|
||||
, try parseLambdaExpressionM
|
||||
, try parseListLiteralM
|
||||
, try parseApplicationM
|
||||
, try parseTreeTermM
|
||||
, parseLiteralM
|
||||
]
|
||||
|
||||
scnParser :: Parser ()
|
||||
scnParser = skipMany (satisfy isNewline)
|
||||
parseFunctionM :: ParserM TricuAST
|
||||
parseFunctionM = do
|
||||
LIdentifier name <- satisfyM isIdentifier
|
||||
args <- many (satisfyM isIdentifier)
|
||||
_ <- satisfyM (== LAssign)
|
||||
scnParserM
|
||||
body <- parseExpressionM
|
||||
pure (SFunc name (map getIdentifier args) body)
|
||||
|
||||
parseFunction :: Parser TricuAST
|
||||
parseFunction = do
|
||||
LIdentifier name <- satisfy isIdentifier
|
||||
args <- many (satisfy isIdentifier)
|
||||
satisfy (== LAssign)
|
||||
body <- parseExpression
|
||||
return (SFunc name (map getIdentifier args) body)
|
||||
parseLambdaM :: ParserM TricuAST
|
||||
parseLambdaM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
|
||||
_ <- satisfyM (== LBackslash)
|
||||
param <- satisfyM isIdentifier
|
||||
rest <- many (satisfyM isIdentifier)
|
||||
_ <- satisfyM (== LColon)
|
||||
scnParserM
|
||||
body <- parseLambdaExpressionM
|
||||
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
|
||||
pure (SLambda [getIdentifier param] nested)
|
||||
|
||||
parseAtomicBase :: Parser TricuAST
|
||||
parseAtomicBase = choice
|
||||
[ parseTreeLeaf
|
||||
, parseGrouped
|
||||
]
|
||||
|
||||
parseLambda :: Parser TricuAST
|
||||
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
|
||||
satisfy (== LBackslash)
|
||||
param <- satisfy isIdentifier
|
||||
rest <- many (satisfy isIdentifier)
|
||||
satisfy (== LColon)
|
||||
body <- parseLambdaExpression
|
||||
let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
|
||||
return (SLambda [getIdentifier param] nestedLambda)
|
||||
|
||||
parseLambdaExpression :: Parser TricuAST
|
||||
parseLambdaExpression = choice
|
||||
[ try parseLambdaApplication
|
||||
, parseAtomicLambda
|
||||
parseLambdaExpressionM :: ParserM TricuAST
|
||||
parseLambdaExpressionM = choice
|
||||
[ try parseLambdaApplicationM
|
||||
, parseAtomicLambdaM
|
||||
]
|
||||
|
||||
parseAtomicLambda :: Parser TricuAST
|
||||
parseAtomicLambda = choice
|
||||
[ parseVar
|
||||
, parseTreeLeaf
|
||||
, parseLiteral
|
||||
, parseListLiteral
|
||||
, try parseLambda
|
||||
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
|
||||
parseAtomicLambdaM :: ParserM TricuAST
|
||||
parseAtomicLambdaM = choice
|
||||
[ parseVarM
|
||||
, parseTreeLeafM
|
||||
, parseLiteralM
|
||||
, parseListLiteralM
|
||||
, try parseLambdaM
|
||||
, between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
|
||||
]
|
||||
|
||||
parseApplication :: Parser TricuAST
|
||||
parseApplication = do
|
||||
func <- parseAtomicBase
|
||||
args <- many parseAtomic
|
||||
return $ foldl (\acc arg -> SApp acc arg) func args
|
||||
parseApplicationM :: ParserM TricuAST
|
||||
parseApplicationM = do
|
||||
func <- parseAtomicBaseM
|
||||
scnParserM
|
||||
args <- many $ do
|
||||
scnParserM
|
||||
arg <- parseAtomicM
|
||||
return arg
|
||||
return $ foldl SApp func args
|
||||
|
||||
parseLambdaApplication :: Parser TricuAST
|
||||
parseLambdaApplication = do
|
||||
func <- parseAtomicLambda
|
||||
args <- many parseAtomicLambda
|
||||
return $ foldl (\acc arg -> SApp acc arg) func args
|
||||
parseLambdaApplicationM :: ParserM TricuAST
|
||||
parseLambdaApplicationM = do
|
||||
func <- parseAtomicLambdaM
|
||||
scnParserM
|
||||
args <- many $ do
|
||||
arg <- parseAtomicLambdaM
|
||||
scnParserM
|
||||
pure arg
|
||||
pure $ foldl SApp func args
|
||||
|
||||
isTreeTerm :: TricuAST -> Bool
|
||||
isTreeTerm TLeaf = True
|
||||
isTreeTerm (TStem _) = True
|
||||
isTreeTerm (TFork _ _) = True
|
||||
isTreeTerm _ = False
|
||||
parseAtomicBaseM :: ParserM TricuAST
|
||||
parseAtomicBaseM = choice
|
||||
[ parseTreeLeafM
|
||||
, parseGroupedM
|
||||
]
|
||||
|
||||
parseTreeLeaf :: Parser TricuAST
|
||||
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
|
||||
parseTreeLeafM :: ParserM TricuAST
|
||||
parseTreeLeafM = do
|
||||
_ <- satisfyM isKeywordT
|
||||
notFollowedBy (lift (satisfy (== LAssign)))
|
||||
pure TLeaf
|
||||
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
getIdentifier _ = error "Expected identifier"
|
||||
|
||||
parseTreeTerm :: Parser TricuAST
|
||||
parseTreeTerm = do
|
||||
base <- parseTreeLeafOrParenthesized
|
||||
rest <- many parseTreeLeafOrParenthesized
|
||||
pure $ foldl combine base rest
|
||||
parseTreeTermM :: ParserM TricuAST
|
||||
parseTreeTermM = do
|
||||
base <- parseTreeLeafOrParenthesizedM
|
||||
rest <- many parseTreeLeafOrParenthesizedM
|
||||
pure (foldl combine base rest)
|
||||
where
|
||||
combine acc next
|
||||
| TLeaf <- acc = TStem next
|
||||
| TStem t <- acc = TFork t next
|
||||
| TFork _ _ <- acc = TFork acc next
|
||||
|
||||
parseTreeLeafOrParenthesized :: Parser TricuAST
|
||||
parseTreeLeafOrParenthesized = choice
|
||||
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
|
||||
, parseTreeLeaf
|
||||
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
|
||||
parseTreeLeafOrParenthesizedM = choice
|
||||
[ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
|
||||
, parseTreeLeafM
|
||||
]
|
||||
|
||||
foldTree :: [TricuAST] -> TricuAST
|
||||
foldTree [] = TLeaf
|
||||
foldTree [x] = x
|
||||
foldTree (x:y:rest) = TFork x (foldTree (y:rest))
|
||||
|
||||
parseAtomic :: Parser TricuAST
|
||||
parseAtomic = choice
|
||||
[ parseVar
|
||||
, parseTreeLeaf
|
||||
, parseListLiteral
|
||||
, parseGrouped
|
||||
, parseLiteral
|
||||
parseAtomicM :: ParserM TricuAST
|
||||
parseAtomicM = choice
|
||||
[ parseVarM
|
||||
, parseTreeLeafM
|
||||
, parseListLiteralM
|
||||
, parseGroupedM
|
||||
, parseLiteralM
|
||||
]
|
||||
|
||||
parseGrouped :: Parser TricuAST
|
||||
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
|
||||
parseGroupedM :: ParserM TricuAST
|
||||
parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
|
||||
scnParserM *> parseExpressionM <* scnParserM
|
||||
|
||||
parseLiteral :: Parser TricuAST
|
||||
parseLiteral = choice
|
||||
[ parseIntLiteral
|
||||
, parseStrLiteral
|
||||
parseLiteralM :: ParserM TricuAST
|
||||
parseLiteralM = choice
|
||||
[ parseIntLiteralM
|
||||
, parseStrLiteralM
|
||||
]
|
||||
|
||||
parens :: Parser TricuAST -> Parser TricuAST
|
||||
parens p = do
|
||||
satisfy (== LOpenParen)
|
||||
result <- p
|
||||
satisfy (== LCloseParen)
|
||||
return result
|
||||
parseListLiteralM :: ParserM TricuAST
|
||||
parseListLiteralM = do
|
||||
_ <- satisfyM (== LOpenBracket)
|
||||
elements <- many parseListItemM
|
||||
_ <- satisfyM (== LCloseBracket)
|
||||
pure (SList elements)
|
||||
|
||||
parseListLiteral :: Parser TricuAST
|
||||
parseListLiteral = do
|
||||
satisfy (== LOpenBracket)
|
||||
elements <- many parseListItem
|
||||
satisfy (== LCloseBracket)
|
||||
return (SList elements)
|
||||
|
||||
parseListItem :: Parser TricuAST
|
||||
parseListItem = choice
|
||||
[ parseGroupedItem
|
||||
, parseListLiteral
|
||||
, parseSingleItem
|
||||
parseListItemM :: ParserM TricuAST
|
||||
parseListItemM = choice
|
||||
[ parseGroupedItemM
|
||||
, parseListLiteralM
|
||||
, parseSingleItemM
|
||||
]
|
||||
|
||||
parseGroupedItem :: Parser TricuAST
|
||||
parseGroupedItem = do
|
||||
satisfy (== LOpenParen)
|
||||
inner <- parseExpression
|
||||
satisfy (== LCloseParen)
|
||||
return inner
|
||||
parseGroupedItemM :: ParserM TricuAST
|
||||
parseGroupedItemM = do
|
||||
_ <- satisfyM (== LOpenParen)
|
||||
inner <- parseExpressionM
|
||||
_ <- satisfyM (== LCloseParen)
|
||||
pure inner
|
||||
|
||||
parseSingleItem :: Parser TricuAST
|
||||
parseSingleItem = do
|
||||
token <- satisfy isListItem
|
||||
parseSingleItemM :: ParserM TricuAST
|
||||
parseSingleItemM = do
|
||||
token <- satisfyM isListItem
|
||||
case token of
|
||||
_ | LIdentifier name <- token -> return (SVar name)
|
||||
| LKeywordT <- token -> return TLeaf
|
||||
| otherwise -> fail "Unexpected token in list item"
|
||||
LIdentifier name -> pure (SVar name)
|
||||
LKeywordT -> pure TLeaf
|
||||
_ -> fail "Unexpected token in list item"
|
||||
|
||||
parseVarM :: ParserM TricuAST
|
||||
parseVarM = do
|
||||
LIdentifier name <- satisfyM isIdentifier
|
||||
if name == "t" || name == "__result"
|
||||
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
else pure (SVar name)
|
||||
|
||||
parseIntLiteralM :: ParserM TricuAST
|
||||
parseIntLiteralM = do
|
||||
LIntegerLiteral value <- satisfyM isIntegerLiteral
|
||||
pure (SInt value)
|
||||
|
||||
parseStrLiteralM :: ParserM TricuAST
|
||||
parseStrLiteralM = do
|
||||
LStringLiteral value <- satisfyM isStringLiteral
|
||||
pure (SStr value)
|
||||
|
||||
isKeywordT :: LToken -> Bool
|
||||
isKeywordT LKeywordT = True
|
||||
isKeywordT _ = False
|
||||
|
||||
isIdentifier :: LToken -> Bool
|
||||
isIdentifier (LIdentifier _) = True
|
||||
isIdentifier _ = False
|
||||
|
||||
isIntegerLiteral :: LToken -> Bool
|
||||
isIntegerLiteral (LIntegerLiteral _) = True
|
||||
isIntegerLiteral _ = False
|
||||
|
||||
isStringLiteral :: LToken -> Bool
|
||||
isStringLiteral (LStringLiteral _) = True
|
||||
isStringLiteral _ = False
|
||||
|
||||
isLiteral :: LToken -> Bool
|
||||
isLiteral (LIntegerLiteral _) = True
|
||||
isLiteral (LStringLiteral _) = True
|
||||
isLiteral _ = False
|
||||
|
||||
isListItem :: LToken -> Bool
|
||||
isListItem (LIdentifier _) = True
|
||||
isListItem LKeywordT = True
|
||||
isListItem _ = False
|
||||
isListItem LKeywordT = True
|
||||
isListItem _ = False
|
||||
|
||||
parseVar :: Parser TricuAST
|
||||
parseVar = do
|
||||
LIdentifier name <- satisfy isIdentifier
|
||||
if (name == "t" || name == "__result")
|
||||
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
|
||||
else return (SVar name)
|
||||
isNewline :: LToken -> Bool
|
||||
isNewline LNewline = True
|
||||
isNewline _ = False
|
||||
|
||||
parseIntLiteral :: Parser TricuAST
|
||||
parseIntLiteral = do
|
||||
LIntegerLiteral value <- satisfy isIntegerLiteral
|
||||
return (SInt value)
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
getIdentifier _ = error "Expected identifier"
|
||||
|
||||
parseStrLiteral :: Parser TricuAST
|
||||
parseStrLiteral = do
|
||||
LStringLiteral value <- satisfy isStringLiteral
|
||||
return (SStr value)
|
||||
|
||||
-- Boolean Helpers
|
||||
isKeywordT (LKeywordT) = True
|
||||
isKeywordT _ = False
|
||||
isIdentifier (LIdentifier _) = True
|
||||
isIdentifier _ = False
|
||||
isIntegerLiteral (LIntegerLiteral _) = True
|
||||
isIntegerLiteral _ = False
|
||||
isStringLiteral (LStringLiteral _) = True
|
||||
isStringLiteral _ = False
|
||||
isLiteral (LIntegerLiteral _) = True
|
||||
isLiteral (LStringLiteral _) = True
|
||||
isLiteral _ = False
|
||||
isNewline (LNewline) = True
|
||||
isNewline _ = False
|
||||
|
||||
-- Alternative parsers
|
||||
altSC :: AltParser ()
|
||||
altSC = skipMany (char ' ' <|> char '\t' <|> char '\n')
|
||||
|
||||
parseTernaryTerm :: AltParser TricuAST
|
||||
parseTernaryTerm = do
|
||||
altSC
|
||||
term <- choice parseTernaryTerm'
|
||||
altSC
|
||||
pure term
|
||||
where
|
||||
parseTernaryTerm' =
|
||||
[ try (between (char '(') (char ')') parseTernaryTerm)
|
||||
, try parseTernaryLeaf
|
||||
, try parseTernaryStem
|
||||
, try parseTernaryFork
|
||||
]
|
||||
|
||||
parseTernaryLeaf :: AltParser TricuAST
|
||||
parseTernaryLeaf = char '0' *> pure TLeaf
|
||||
|
||||
parseTernaryStem :: AltParser TricuAST
|
||||
parseTernaryStem = char '1' *> (TStem <$> parseTernaryTerm)
|
||||
|
||||
parseTernaryFork :: AltParser TricuAST
|
||||
parseTernaryFork = do
|
||||
char '2'
|
||||
term1 <- parseTernaryTerm
|
||||
term2 <- parseTernaryTerm
|
||||
pure $ TFork term1 term2
|
||||
|
||||
parseTernary :: String -> Either String TricuAST
|
||||
parseTernary input
|
||||
| Left err <- result = Left (errorBundlePretty err)
|
||||
| Right ast <- result = Right ast
|
||||
where
|
||||
result = runParser (parseTernaryTerm <* eof) "" input
|
||||
|
||||
-- Error Handling
|
||||
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
||||
handleParseError bundle =
|
||||
let errors = bundleErrors bundle
|
||||
errorList = toList errors
|
||||
formattedErrors = map showError errorList
|
||||
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
||||
let errors = bundleErrors bundle
|
||||
errorList = Data.List.NonEmpty.toList errors
|
||||
formattedErrs = map showError errorList
|
||||
in unlines ("Parse error(s) encountered:" : formattedErrs)
|
||||
|
||||
showError :: ParseError [LToken] Void -> String
|
||||
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
|
||||
"Parse error at offset " ++ show offset ++ ": unexpected token "
|
||||
++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
|
||||
"Parse error at offset " ++ show offset
|
||||
++ ": unexpected token " ++ show tokenStream
|
||||
++ ", expected one of " ++ show (Set.toList expected)
|
||||
showError (FancyError offset fancy) =
|
||||
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
|
||||
"Parse error at offset " ++ show offset ++ ":\n "
|
||||
++ unlines (map show (Set.toList fancy))
|
||||
showError (TrivialError offset Nothing expected) =
|
||||
"Parse error at offset " ++ show offset ++ ": expected one of "
|
||||
++ show (Set.toList expected)
|
||||
"Parse error at offset " ++ show offset
|
||||
++ ": expected one of " ++ show (Set.toList expected)
|
||||
|
||||
|
||||
10
test/Spec.hs
10
test/Spec.hs
@ -71,9 +71,9 @@ lexerTests = testGroup "Lexer Tests"
|
||||
parserTests :: TestTree
|
||||
parserTests = testGroup "Parser Tests"
|
||||
[ testCase "Error when assigning a value to T" $ do
|
||||
let input = lexTricu "t = x"
|
||||
case (runParser parseExpression "" input) of
|
||||
Left _ -> return ()
|
||||
let tokens = lexTricu "t = x"
|
||||
case parseSingleExpr tokens of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
|
||||
, testCase "Parse function definitions" $ do
|
||||
let input = "x = (\\a b c : a)"
|
||||
@ -149,10 +149,6 @@ parserTests = testGroup "Parser Tests"
|
||||
let input = "(t) -- (t) -- (t)"
|
||||
expect = [TLeaf]
|
||||
parseTricu input @?= expect
|
||||
, testCase "Comments with no terms" $ do
|
||||
let input = unlines ["-- (t)", "(t t)"]
|
||||
expect = [SEmpty,SApp TLeaf TLeaf]
|
||||
parseTricu input @?= expect
|
||||
]
|
||||
|
||||
evaluationTests :: TestTree
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: tricu
|
||||
version: 0.5.0
|
||||
version: 0.6.0
|
||||
description: A micro-language for exploring Tree Calculus
|
||||
author: James Eversole
|
||||
maintainer: james@eversole.co
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user