summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs11
-rw-r--r--src/Parser/Expr.hs29
2 files changed, 33 insertions, 7 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index e1a4035..c12afdd 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -273,6 +273,17 @@ unifySomeExpr off stype sexpr@(SomeExpr expr)
_ <- unify off (ExprTypeVar tvar) (someExprType sexpr)
return sexpr
+ | ExprTypeFunction args res <- stype
+ = case someExprType sexpr of
+ ExprTypeFunction args' res' -> do
+ _ <- unify off args args'
+ _ <- unify off res res'
+ return sexpr
+ _ -> do
+ _ <- unify off args (ExprTypeArguments mempty)
+ SomeExpr expr' <- unifySomeExpr off res sexpr
+ return $ SomeExpr $ FunctionAbstraction expr'
+
| otherwise
= do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index c12d004..16c2b45 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -162,7 +162,7 @@ quotedString = label "string" $ lexeme $ do
regex :: TestParser (Expr Regex)
regex = label "regular expression" $ lexeme $ do
off <- stateOffset <$> getParserState
- void $ char '/'
+ void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes
let inner = choice
[ char '/' >> return []
, takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner
@@ -418,12 +418,27 @@ constructor = label "constructor" $ do
functionCall :: TestParser SomeExpr
functionCall = do
sline <- getSourceLine
- (variable <|> constructor) >>= \case
- SomeExpr e'@(FunVariable argTypes _ _) -> do
- let check = checkFunctionArguments argTypes
- args <- functionArguments check (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)
- return $ SomeExpr $ ArgsApp args e'
- e -> return e
+ off <- stateOffset <$> getParserState
+
+ fun <- variable <|> constructor
+ FunctionArguments margs <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName)
+ if M.null margs
+ then return fun
+ else do
+ dict <- newTypeVar
+ res <- newTypeVar
+ SomeExpr (expr :: Expr fa) <- unifySomeExpr off (ExprTypeFunction (ExprTypeVar dict) (ExprTypeVar res)) fun
+ Just (ExprTypeArguments argTypes) <- M.lookup dict <$> gets testTypeUnif
+ args <- fmap (FunctionArguments . M.fromAscList) $ mapM (\( kw, ( poff, e ) ) -> ( kw, ) <$> checkFunctionArguments argTypes poff kw e) $ M.toAscList margs
+ M.lookup res <$> gets testTypeUnif >>= \case
+ Just (ExprTypePrim (_ :: Proxy a))
+ | Just (Refl :: FunctionType a :~: fa) <- eqT
+ -> return $ SomeExpr $ ArgsApp args expr
+ | otherwise -> error $ "type mismatch after function unification: " <> show ( typeRep (Proxy @(FunctionType a)), typeRep (Proxy @fa) )
+ _
+ | Just (Refl :: FunctionType DynamicType :~: fa) <- eqT
+ -> return $ SomeExpr $ ArgsApp args expr
+ | otherwise -> error $ "type mismatch after function unification: " <> show ( typeRep (Proxy @(FunctionType DynamicType)), typeRep (Proxy @fa) )
recordSelector :: SomeExpr -> TestParser SomeExpr
recordSelector (SomeExpr expr) = do