summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs210
1 files changed, 180 insertions, 30 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 3c43a69..9f1a0e3 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -1,74 +1,224 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module Parser (
- parseTestFile,
+ parseTestFiles,
+ CustomTestError(..),
) where
import Control.Monad
+import Control.Monad.Except
import Control.Monad.State
-import Control.Monad.Writer
+import Data.IORef
+import Data.Map qualified as M
import Data.Maybe
+import Data.Proxy
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
+import Data.Void
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
import System.Directory
-import System.Exit
import System.FilePath
+import System.IO.Error
+import Asset
+import Network
import Parser.Core
import Parser.Expr
import Parser.Statement
+import Script.Expr
+import Script.Module
import Test
import Test.Builtins
-parseTestDefinition :: TestParser ()
+parseTestDefinition :: TestParser Toplevel
parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
- block (\name steps -> return $ Test name $ concat steps) header testStep
- where header = do
- wsymbol "test"
- lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+ localState $ do
+ modify $ \s -> s
+ { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
+ }
+ block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep
+ where
+ header = do
+ wsymbol "test"
+ lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
+
+parseDefinition :: Pos -> TestParser ( VarName, SomeExpr )
+parseDefinition href = label "symbol definition" $ do
+ def@( name, expr ) <- localState $ do
+ wsymbol "def"
+ name <- varName
+ argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)
+ atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do
+ tvar <- newTypeVar
+ modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s }
+ return ( off, vname, tvar )
+ SomeExpr expr <- choice
+ [ do
+ osymbol ":"
+ scn
+ ref <- L.indentGuard scn GT href
+ SomeExpr <$> testBlock ref
+ , do
+ osymbol "="
+ someExpr <* eol
+ ]
+ scn
+ atypes' <- getInferredTypes atypes
+ sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr
+ return ( name, sexpr )
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
+ return def
+ where
+ getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
+ let err msg = do
+ registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg
+ return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )
+ gets (M.lookup tvar . testTypeUnif) >>= \case
+ Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) )
+ Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’"
+ Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’"
+ Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"
+
+ replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)
+ replaceDynArgs expr = do
+ unif <- gets testTypeUnif
+ return $ mapExpr (go unif) expr
+ where
+ go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b
+ go unif = \case
+ ArgsApp args body -> ArgsApp (fmap replaceArgs args) body
+ where
+ replaceArgs (SomeExpr (DynVariable tvar sline vname))
+ | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif
+ = SomeExpr (Variable sline vname :: Expr v)
+ replaceArgs (SomeExpr e) = SomeExpr (go unif e)
+ e -> e
+
+parseAsset :: Pos -> TestParser ( VarName, SomeExpr )
+parseAsset href = label "asset definition" $ do
+ wsymbol "asset"
+ name <- varName
+ osymbol ":"
+ void eol
+ ref <- L.indentGuard scn GT href
+
+ wsymbol "path"
+ osymbol ":"
+ off <- stateOffset <$> getParserState
+ path <- TL.unpack <$> takeWhile1P Nothing (/= '\n')
+ dir <- takeDirectory <$> gets testSourcePath
+ absPath <- liftIO (makeAbsolute $ dir </> path)
+ let assetPath = AssetPath absPath
+ liftIO (doesPathExist absPath) >>= \case
+ True -> return ()
+ False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath
+
+ void $ L.indentGuard scn LT ref
+ let expr = SomeExpr $ Pure Asset {..}
+ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s }
+ return ( name, expr )
+
+parseExport :: TestParser [ Toplevel ]
+parseExport = label "export declaration" $ toplevel id $ do
+ ref <- L.indentLevel
+ wsymbol "export"
+ choice
+ [ do
+ def@( name, _ ) <- parseDefinition ref <|> parseAsset ref
+ return [ ToplevelDefinition def, ToplevelExport name ]
+ , do
+ names <- listOf varName
+ eol >> scn
+ return $ map ToplevelExport names
+ ]
+
+parseImport :: TestParser [ Toplevel ]
+parseImport = label "import declaration" $ toplevel (\() -> []) $ do
+ wsymbol "import"
+ modName <- parseModuleName
+ importedModule <- getOrParseModule modName
+ modify $ \s -> s { testVars = map (fmap (fmap someExprType)) (moduleExportedDefinitions importedModule) ++ testVars s }
+ eol >> scn
parseTestModule :: FilePath -> TestParser Module
parseTestModule absPath = do
+ scn
moduleName <- choice
[ label "module declaration" $ do
wsymbol "module"
off <- stateOffset <$> getParserState
- x <- identifier
- name <- (x:) <$> many (symbol "." >> identifier)
- when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
+ name@(ModuleName tname) <- parseModuleName
+ when (or (zipWith (/=) (reverse tname) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
"module name does not match file path"
eol >> scn
return name
, do
- return $ [ T.pack $ takeBaseName absPath ]
+ return $ ModuleName [ T.pack $ takeBaseName absPath ]
]
- (_, toplevels) <- listen $ many $ choice
- [ parseTestDefinition
+ modify $ \s -> s { testCurrentModuleName = moduleName }
+ toplevels <- fmap concat $ many $ choice
+ [ (: []) <$> parseTestDefinition
+ , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1)
+ , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1)
+ , parseExport
+ , parseImport
]
- let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels
+ let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels
+ moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels
+ moduleExports = catMaybes $ map (\case ToplevelExport x -> Just x; _ -> Nothing) toplevels
eof
- return Module { .. }
+ return Module {..}
-parseTestFile :: FilePath -> IO Module
-parseTestFile path = do
- content <- TL.readFile path
- absPath <- makeAbsolute path
- let initState = TestParserState
- { testVars = concat
- [ map (fmap someVarValueType) builtins
- ]
- , testContext = SomeExpr RootNetwork
- }
- (res, _) = flip evalState initState $ runWriterT $ runParserT (parseTestModule absPath) path content
+parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))
+parseTestFiles paths = do
+ parsedModules <- newIORef []
+ runExceptT $ do
+ requestedModules <- reverse <$> foldM (go parsedModules) [] paths
+ allModules <- map snd <$> liftIO (readIORef parsedModules)
+ return ( requestedModules, allModules )
+ where
+ go parsedModules res path = do
+ liftIO (parseTestFile parsedModules Nothing path) >>= \case
+ Left err -> do
+ throwError err
+ Right cur -> do
+ return $ cur : res
- case res of
- Left err -> putStr (errorBundlePretty err) >> exitFailure
- Right testModule -> return testModule
+parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)
+parseTestFile parsedModules mbModuleName path = do
+ absPath <- makeAbsolute path
+ (lookup absPath <$> readIORef parsedModules) >>= \case
+ Just found -> return $ Right found
+ Nothing -> do
+ let initState = TestParserState
+ { testSourcePath = path
+ , testVars = concat
+ [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someVarValueType value ))) $ M.toList builtins
+ ]
+ , testContext = SomeExpr (Undefined "void" :: Expr Void)
+ , testNextTypeVar = 0
+ , testTypeUnif = M.empty
+ , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName
+ , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do
+ let projectRoot = iterate takeDirectory absPath !! length current
+ parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
+ }
+ mbContent <- (Just <$> TL.readFile path) `catchIOError` \e ->
+ if isDoesNotExistError e then return Nothing else ioError e
+ case mbContent of
+ Just content -> do
+ runTestParser content initState (parseTestModule absPath) >>= \case
+ Left bundle -> do
+ return $ Left $ ImportModuleError bundle
+ Right testModule -> do
+ modifyIORef parsedModules (( absPath, testModule ) : )
+ return $ Right testModule
+ Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-09 22:31:02 +0000