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.hs239
1 files changed, 226 insertions, 13 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index 2a74d3d..132dbc8 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -1,37 +1,218 @@
module Parser.Core where
+import Control.Applicative
import Control.Monad
import Control.Monad.State
-import Control.Monad.Writer
-import Data.Text (Text)
-import qualified Data.Text.Lazy as TL
-import Data.Void
+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 Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Network ()
+import Script.Expr
+import Script.Module
import Test
-type TestParser = ParsecT Void TestStream (WriterT [ Toplevel ] (State TestParserState))
+newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a)
+ deriving
+ ( Functor, Applicative, Alternative, Monad
+ , MonadState TestParserState
+ , MonadPlus
+ , MonadFail
+ , MonadIO
+ , MonadParsec CustomTestError TestStream
+ )
type TestStream = TL.Text
+type TestParseError = ParseError TestStream CustomTestError
+
+data CustomTestError
+ = ModuleNotFound ModuleName
+ | FileNotFound FilePath
+ | ImportModuleError (ParseErrorBundle TestStream CustomTestError)
+ deriving (Eq)
+
+instance Ord CustomTestError where
+ compare (ModuleNotFound a) (ModuleNotFound b) = compare a b
+ compare (ModuleNotFound _) _ = LT
+ compare _ (ModuleNotFound _) = GT
+
+ compare (FileNotFound a) (FileNotFound b) = compare a b
+ compare (FileNotFound _) _ = LT
+ compare _ (FileNotFound _) = GT
+
+ -- Ord instance is required to store errors in Set, but there shouldn't be
+ -- two ImportModuleErrors at the same possition, so "dummy" comparison
+ -- should be ok.
+ compare (ImportModuleError _) (ImportModuleError _) = EQ
+
+instance ShowErrorComponent CustomTestError where
+ showErrorComponent (ModuleNotFound name) = "module ‘" <> T.unpack (textModuleName name) <> "’ not found"
+ showErrorComponent (FileNotFound path) = "file ‘" <> path <> "’ not found"
+ showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle
+
+runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a)
+runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser
+
data Toplevel
= ToplevelTest Test
+ | ToplevelDefinition ( VarName, SomeExpr )
+ | ToplevelExport VarName
+ | ToplevelImport ( ModuleName, VarName )
data TestParserState = TestParserState
- { testVars :: [(VarName, SomeExprType)]
+ { testSourcePath :: FilePath
+ , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]
, testContext :: SomeExpr
+ , testNextTypeVar :: Int
+ , testTypeUnif :: Map TypeVar SomeExprType
+ , testCurrentModuleName :: ModuleName
+ , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module)
}
-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 ( FqVarName, 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
+ let fqName = LocalVarName name
+ modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s }
+ return ( fqName, vtype )
+ Just ( fqName, t@(ExprTypeVar tvar) ) -> do
+ ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif)
+ Just x -> return x
+
+lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupVarExpr off sline name = do
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
+
+lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
+lookupScalarVarExpr off sline name = do
+ ( fqn, etype ) <- lookupVarType off name
+ case etype of
+ ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
+ ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline fqn
+ ExprTypeFunction args (pa :: Proxy a) -> do
+ SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: 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 "#"
@@ -61,11 +242,12 @@ localState :: TestParser a -> TestParser a
localState inner = do
s <- get
x <- inner
- put s
+ s' <- get
+ put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' }
return x
-toplevel :: (a -> Toplevel) -> TestParser a -> TestParser ()
-toplevel f = tell . (: []) . f <=< L.nonIndented scn
+toplevel :: (a -> b) -> TestParser a -> TestParser b
+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 +262,34 @@ listOf :: TestParser a -> TestParser [a]
listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
+
+blockOf :: Monoid a => Pos -> TestParser a -> TestParser a
+blockOf indent step = go
+ where
+ go = do
+ scn
+ pos <- L.indentLevel
+ optional eof >>= \case
+ Just _ -> return mempty
+ _ | pos < indent -> return mempty
+ | pos == indent -> mappend <$> step <*> go
+ | otherwise -> L.incorrectIndent EQ indent pos
+
+
+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
+ ]
+
+
+getOrParseModule :: ModuleName -> TestParser Module
+getOrParseModule name = do
+ current <- gets testCurrentModuleName
+ parseModule <- gets testParseModule
+ (TestParser $ lift $ lift $ parseModule current name) >>= \case
+ Right parsed -> return parsed
+ Left err -> customFailure err
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-14 19:13:58 +0000