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