diff options
Diffstat (limited to 'src/Parser.hs')
| -rw-r--r-- | src/Parser.hs | 69 |
1 files changed, 34 insertions, 35 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index d90b796..9f1a0e3 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -2,9 +2,11 @@ module Parser ( parseTestFiles, + CustomTestError(..), ) where import Control.Monad +import Control.Monad.Except import Control.Monad.State import Data.IORef @@ -22,7 +24,6 @@ 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 @@ -42,15 +43,15 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do modify $ \s -> s { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar } - block (\name steps -> return $ Test name $ mconcat steps) header testStep + block (\name steps -> return $ Test name $ Scope <$> mconcat steps) header testStep where header = do wsymbol "test" lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') -parseDefinition :: TestParser ( VarName, SomeExpr ) -parseDefinition = label "symbol definition" $ do - def@( name, expr ) <- localState $ L.indentBlock scn $ do +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) @@ -58,19 +59,20 @@ parseDefinition = label "symbol definition" $ do tvar <- newTypeVar modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s } return ( off, vname, tvar ) - choice + SomeExpr expr <- choice [ do osymbol ":" - let finish steps = do - atypes' <- getInferredTypes atypes - ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps) - return $ L.IndentSome Nothing finish testStep + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref , do osymbol "=" - SomeExpr (expr :: Expr e) <- someExpr - atypes' <- getInferredTypes atypes - L.IndentNone . ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + 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 @@ -99,13 +101,13 @@ parseDefinition = label "symbol definition" $ do replaceArgs (SomeExpr e) = SomeExpr (go unif e) e -> e -parseAsset :: TestParser ( VarName, SomeExpr ) -parseAsset = label "asset definition" $ do +parseAsset :: Pos -> TestParser ( VarName, SomeExpr ) +parseAsset href = label "asset definition" $ do wsymbol "asset" name <- varName osymbol ":" void eol - ref <- L.indentGuard scn GT pos1 + ref <- L.indentGuard scn GT href wsymbol "path" osymbol ":" @@ -125,10 +127,11 @@ parseAsset = label "asset definition" $ do parseExport :: TestParser [ Toplevel ] parseExport = label "export declaration" $ toplevel id $ do + ref <- L.indentLevel wsymbol "export" choice [ do - def@( name, _ ) <- parseDefinition <|> parseAsset + def@( name, _ ) <- parseDefinition ref <|> parseAsset ref return [ ToplevelDefinition def, ToplevelExport name ] , do names <- listOf varName @@ -163,8 +166,8 @@ parseTestModule absPath = do modify $ \s -> s { testCurrentModuleName = moduleName } toplevels <- fmap concat $ many $ choice [ (: []) <$> parseTestDefinition - , (: []) <$> toplevel ToplevelDefinition parseDefinition - , (: []) <$> toplevel ToplevelDefinition parseAsset + , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) + , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) , parseExport , parseImport ] @@ -174,27 +177,23 @@ parseTestModule absPath = do eof return Module {..} -parseTestFiles :: [ FilePath ] -> IO ( [ Module ], [ Module ] ) +parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) parseTestFiles paths = do parsedModules <- newIORef [] - requestedModules <- reverse <$> foldM (go parsedModules) [] paths - allModules <- map snd <$> readIORef parsedModules - return ( requestedModules, allModules ) + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) where go parsedModules res path = do - let moduleName = error "current module name should be set at the beginning of parseTestModule" - parseTestFile parsedModules moduleName path >>= \case - Left (ImportModuleError bundle) -> do - putStr (errorBundlePretty bundle) - exitFailure + liftIO (parseTestFile parsedModules Nothing path) >>= \case Left err -> do - putStr (showErrorComponent err) - exitFailure + throwError err Right cur -> do return $ cur : res -parseTestFile :: IORef [ ( FilePath, Module ) ] -> ModuleName -> FilePath -> IO (Either CustomTestError Module) -parseTestFile parsedModules moduleName path = do +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 @@ -207,10 +206,10 @@ parseTestFile parsedModules moduleName path = do , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 , testTypeUnif = M.empty - , testCurrentModuleName = moduleName + , 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 mname $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath + 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 @@ -222,4 +221,4 @@ parseTestFile parsedModules moduleName path = do Right testModule -> do modifyIORef parsedModules (( absPath, testModule ) : ) return $ Right testModule - Nothing -> return $ Left $ ModuleNotFound moduleName + Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName |