summaryrefslogtreecommitdiff
path: root/src/Parser/Core.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser/Core.hs')
-rw-r--r--src/Parser/Core.hs171
1 files changed, 160 insertions, 11 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 2a74d3d..10a572b 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,11 +1,17 @@
module Parser.Core where
+import Control.Applicative
import Control.Monad
+import Control.Monad.Identity
import Control.Monad.State
-import Control.Monad.Writer
-import Data.Text (Text)
-import qualified Data.Text.Lazy as TL
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Set qualified as S
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import Data.Typeable
import Data.Void
import Text.Megaparsec hiding (State)
@@ -15,23 +21,156 @@ import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
import Test
-type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState))
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT Void TestStream Identity) a)
+ deriving
+ ( Functor, Applicative, Alternative, Monad
+ , MonadState TestParserState
+ , MonadPlus
+ , MonadFail
+ , MonadParsec Void TestStream
+ )
type TestStream = TL.Text
+type TestParseError = ParseError TestStream Void
+
+runTestParser :: String -> TestStream -> TestParserState -> TestParser a -> Either (ParseErrorBundle TestStream Void) a
+runTestParser path content initState (TestParser parser) = runIdentity . flip (flip runParserT path) content . flip evalStateT initState $ parser
+
data Toplevel
= ToplevelTest Test
+ | ToplevelDefinition ( VarName, SomeVarValue )
data TestParserState = TestParserState
- { testVars :: [(VarName, SomeExprType)]
+ { testVars :: [ ( VarName, SomeExprType ) ]
, testContext :: SomeExpr
+ , testNextTypeVar :: Int
+ , testTypeUnif :: Map TypeVar SomeExprType
}
-textSomeExprType :: SomeExprType -> Text
-textSomeExprType (SomeExprType p) = textExprType p
+newTypeVar :: TestParser TypeVar
+newTypeVar = do
+ idx <- gets testNextTypeVar
+ modify $ \s -> s { testNextTypeVar = idx + 1 }
+ return $ TypeVar $ T.pack $ 'a' : show idx
+
+lookupVarType :: Int -> VarName -> TestParser SomeExprType
+lookupVarType off name = do
+ gets (lookup name . testVars) >>= \case
+ Nothing -> do
+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "variable not in scope: `" <> textVarName name <> "'"
+ vtype <- ExprTypeVar <$> newTypeVar
+ modify $ \s -> s { testVars = ( name, vtype ) : testVars s }
+ return vtype
+ Just t@(ExprTypeVar tvar) -> do
+ gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ Just x -> return x
+
+lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupVarExpr off sline name = do
+ lookupVarType off name >>= \case
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a))
+
+unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType
+unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do
+ cur <- gets testTypeUnif
+ case M.lookup aname cur of
+ Just a -> return a
+ Nothing -> return (ExprTypeVar aname)
+
+unify off (ExprTypeVar aname) (ExprTypeVar bname) = do
+ cur <- gets testTypeUnif
+ case ( M.lookup aname cur, M.lookup bname cur ) of
+ ( Just a, Just b ) -> do
+ c <- unify off a b
+ modify $ \s -> s { testTypeUnif = M.insert aname c $ M.insert bname c $ cur }
+ return c
+
+ ( Just a, Nothing ) -> do
+ modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }
+ return a
+
+ ( Nothing, Just b ) -> do
+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
+ return b
+
+ ( Nothing, Nothing ) -> do
+ let b = ExprTypeVar bname
+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
+ return b
+
+unify off (ExprTypeVar aname) b = do
+ cur <- gets testTypeUnif
+ case M.lookup aname cur of
+ Just a -> do
+ c <- unify off a b
+ modify $ \s -> s { testTypeUnif = M.insert aname c $ cur }
+ return c
+ Nothing -> do
+ modify $ \s -> s { testTypeUnif = M.insert aname b $ cur }
+ return b
+
+unify off a (ExprTypeVar bname) = do
+ cur <- gets testTypeUnif
+ case M.lookup bname cur of
+ Just b -> do
+ c <- unify off a b
+ modify $ \s -> s { testTypeUnif = M.insert bname c $ cur }
+ return c
+
+ Nothing -> do
+ modify $ \s -> s { testTypeUnif = M.insert bname a $ cur }
+ return a
+
+unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b))
+ | Just (Refl :: a :~: b) <- eqT
+ = return res
+
+unify off a b = do
+ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'"
+
+
+unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a)
+unifyExpr off pa expr = if
+ | Just (Refl :: a :~: b) <- eqT
+ -> return expr
+
+ | DynVariable tvar sline name <- expr
+ -> do
+ _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar)
+ return $ Variable sline name
+
+ | Just (Refl :: FunctionType a :~: b) <- eqT
+ -> do
+ let FunctionArguments remaining = exprArgs expr
+ showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'"
+ showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'"
+ err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack
+
+ defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case
+ arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument"
+ (_, SomeArgumentType OptionalArgument) -> return Nothing
+ (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def )
+ (kw, SomeArgumentType atype@ContextDefault) -> do
+ SomeExpr context <- gets testContext
+ context' <- unifyExpr off atype context
+ return $ Just ( kw, SomeExpr context' )
+ return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
+
+ | Just (Refl :: DynamicType :~: b) <- eqT
+ , Undefined msg <- expr
+ -> do
+ return $ Undefined msg
+
+ | otherwise
+ -> do
+ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"
-lookupVarType :: VarName -> TestParser SomeExprType
-lookupVarType name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . testVars)
skipLineComment :: TestParser ()
skipLineComment = L.skipLineComment $ TL.pack "#"
@@ -64,8 +203,8 @@ localState inner = do
put s
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
-toplevel f = tell . (: []) . f <=< L.nonIndented scn
+toplevel :: (a -> Toplevel) -> TestParser a -> TestParser Toplevel
+toplevel f = return . f <=< L.nonIndented scn
block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c
block merge header item = L.indentBlock scn $ do
@@ -80,3 +219,13 @@ listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+
+
+getSourceLine :: TestParser SourceLine
+getSourceLine = do
+ pstate <- statePosState <$> getParserState
+ return $ SourceLine $ T.concat
+ [ T.pack $ sourcePosPretty $ pstateSourcePos pstate
+ , T.pack ": "
+ , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate
+ ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 03:39:08 +0000