summaryrefslogtreecommitdiff
path: root/src/Parser/Expr.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser/Expr.hs')
-rw-r--r--src/Parser/Expr.hs130
1 files changed, 72 insertions, 58 deletions
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 4ed0215..b9b5f01 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -1,5 +1,6 @@
module Parser.Expr (
identifier,
+ parseModuleName,
varName,
newVarName,
@@ -10,6 +11,8 @@ module Parser.Expr (
literal,
variable,
+ stringExpansion,
+
checkFunctionArguments,
functionArguments,
) where
@@ -33,18 +36,34 @@ import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
-import Text.Regex.TDFA qualified as RE
-import Text.Regex.TDFA.Text qualified as RE
+import Text.Megaparsec.Error.Builder qualified as Err
import Parser.Core
-import Test
+import Script.Expr
+import Script.Expr.Class
+
+reservedWords :: [ Text ]
+reservedWords =
+ [ "test", "def", "let"
+ , "module", "export", "import"
+ ]
identifier :: TestParser Text
identifier = label "identifier" $ do
- lexeme $ do
+ lexeme $ try $ do
+ off <- stateOffset <$> getParserState
lead <- lowerChar
rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_')
- return $ TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest
+ let ident = TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest
+ when (ident `elem` reservedWords) $ parseError $ Err.err off $ mconcat
+ [ Err.utoks $ TL.fromStrict ident
+ ]
+ return ident
+
+parseModuleName :: TestParser ModuleName
+parseModuleName = do
+ x <- identifier
+ ModuleName . (x :) <$> many (symbol "." >> identifier)
varName :: TestParser VarName
varName = label "variable name" $ VarName <$> identifier
@@ -62,7 +81,7 @@ addVarName off (TypedVarName name) = do
Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
T.pack "variable '" <> textVarName name <> T.pack "' already exists"
Nothing -> return ()
- modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s }
+ modify $ \s -> s { testVars = ( name, ( LocalVarName name, ExprTypePrim @a Proxy )) : testVars s }
someExpansion :: TestParser SomeExpr
someExpansion = do
@@ -71,12 +90,12 @@ someExpansion = do
[do off <- stateOffset <$> getParserState
sline <- getSourceLine
name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
- lookupVarExpr off sline name
+ lookupScalarVarExpr off sline name
, between (char '{') (char '}') someExpr
]
-stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a)
-stringExpansion tname conv = do
+expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)
+expressionExpansion tname = do
off <- stateOffset <$> getParserState
SomeExpr e <- someExpansion
let err = do
@@ -84,7 +103,10 @@ stringExpansion tname conv = do
[ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]
return $ Undefined "expansion not defined for type"
- maybe err return $ listToMaybe $ catMaybes $ conv e
+ maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ]
+
+stringExpansion :: TestParser (Expr Text)
+stringExpansion = expressionExpansion "string"
numberLiteral :: TestParser SomeExpr
numberLiteral = label "number" $ lexeme $ do
@@ -96,6 +118,13 @@ numberLiteral = label "number" $ lexeme $ do
else return $ SomeExpr $ Pure x
]
+boolLiteral :: TestParser SomeExpr
+boolLiteral = label "bool" $ lexeme $ do
+ SomeExpr . Pure <$> choice
+ [ wsymbol "True" *> return True
+ , wsymbol "False" *> return False
+ ]
+
quotedString :: TestParser (Expr Text)
quotedString = label "string" $ lexeme $ do
void $ char '"'
@@ -112,11 +141,7 @@ quotedString = label "string" $ lexeme $ do
, char 't' >> return '\t'
]
(Pure (T.singleton c) :) <$> inner
- ,do e <- stringExpansion (T.pack "string") $ \e ->
- [ cast e
- , fmap (T.pack . show @Integer) <$> cast e
- , fmap (T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- stringExpansion
(e:) <$> inner
]
Concat <$> inner
@@ -134,19 +159,14 @@ regex = label "regular expression" $ lexeme $ do
, anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c])
]
(s:) <$> inner
- ,do e <- stringExpansion (T.pack "regex") $ \e ->
- [ cast e
- , fmap RegexString <$> cast e
- , fmap (RegexString . T.pack . show @Integer) <$> cast e
- , fmap (RegexString . T.pack . show @Scientific) <$> cast e
- ]
+ ,do e <- expressionExpansion (T.pack "regex")
(e:) <$> inner
]
parts <- inner
let testEval = \case
Pure (RegexPart p) -> p
_ -> ""
- case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of
+ case regexCompile $ T.concat $ map testEval parts of
Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
[ "failed to parse regular expression: ", T.pack err ]
Right _ -> return ()
@@ -221,7 +241,7 @@ someExpr = join inner <?> "expression"
term = label "term" $ choice
[ parens inner
, return <$> literal
- , return <$> variable
+ , return <$> functionCall
]
table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer)
@@ -248,11 +268,13 @@ someExpr = join inner <?> "expression"
[ SomeBinOp ((==) @Integer)
, SomeBinOp ((==) @Scientific)
, SomeBinOp ((==) @Text)
+ , SomeBinOp ((==) @Bool)
]
, binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $
[ SomeBinOp ((/=) @Integer)
, SomeBinOp ((/=) @Scientific)
, SomeBinOp ((/=) @Text)
+ , SomeBinOp ((/=) @Bool)
]
, binary ">" $
[ SomeBinOp ((>) @Integer)
@@ -334,6 +356,7 @@ typedExpr = do
literal :: TestParser SomeExpr
literal = label "literal" $ choice
[ numberLiteral
+ , boolLiteral
, SomeExpr <$> quotedString
, SomeExpr <$> regex
, list
@@ -344,43 +367,46 @@ variable = label "variable" $ do
off <- stateOffset <$> getParserState
sline <- getSourceLine
name <- varName
- lookupVarExpr off sline name >>= \case
+ e <- lookupVarExpr off sline name
+ recordSelector e <|> return e
+
+functionCall :: TestParser SomeExpr
+functionCall = do
+ sline <- getSourceLine
+ variable >>= \case
SomeExpr e'@(FunVariable argTypes _ _) -> do
let check = checkFunctionArguments argTypes
args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName)
return $ SomeExpr $ ArgsApp args e'
- e -> do
- recordSelector e <|> return e
+ e -> return e
+recordSelector :: SomeExpr -> TestParser SomeExpr
+recordSelector (SomeExpr expr) = do
+ void $ osymbol "."
+ off <- stateOffset <$> getParserState
+ m <- identifier
+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "value of type ", textExprType expr, T.pack " does not have member '", m, T.pack "'" ]
+ e' <- maybe err return $ applyRecordSelector m expr <$> lookup m recordMembers
+ recordSelector e' <|> return e'
where
- recordSelector :: SomeExpr -> TestParser SomeExpr
- recordSelector (SomeExpr e) = do
- void $ osymbol "."
- off <- stateOffset <$> getParserState
- m <- identifier
- let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]
- e' <- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers
- recordSelector e' <|> return e'
-
applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr
applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
checkFunctionArguments :: FunctionArguments SomeArgumentType
-> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr
-checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do
+checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do
case M.lookup kw argTypes of
Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
- withRecovery registerParseError $ do
- void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr)
- return expr
+ withRecovery (\e -> registerParseError e >> return sexpr) $ do
+ SomeExpr <$> unifyExpr poff (Proxy @expected) expr
Nothing -> do
registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
case kw of
- Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'"
+ Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
Nothing -> "unexpected parameter"
- return expr
+ return sexpr
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)
@@ -399,22 +425,10 @@ functionArguments check param lit promote = do
[ T.pack "multiple unnamed parameters" ]
parseArgs False
- ,do off <- stateOffset <$> getParserState
- x <- identifier
- choice
- [do off' <- stateOffset <$> getParserState
- y <- pparam <|> (promote off' =<< identifier)
- checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
-
- ,if allowUnnamed
- then do
- y <- promote off x
- checkAndInsert off Nothing y $ return M.empty
- else do
- registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
- [ T.pack "multiple unnamed parameters" ]
- return M.empty
- ]
+ ,do x <- identifier
+ off <- stateOffset <$> getParserState
+ y <- pparam <|> (promote off =<< identifier)
+ checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed
,do return M.empty
]
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-02 02:43:50 +0000