summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs24
1 files changed, 16 insertions, 8 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 9029e0f..cd9b590 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -6,13 +6,15 @@ module Parser (
import Control.Monad.State
-import Data.Text (Text)
+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 Text.Megaparsec hiding (State)
+import Text.Megaparsec.Char
+import System.Directory
import System.Exit
import System.FilePath
@@ -28,15 +30,21 @@ parseTestDefinition = label "test definition" $ toplevel $ do
wsymbol "test"
lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':')
-parseTestModule :: Text -> TestParser Module
-parseTestModule defaultName = do
+parseTestModule :: FilePath -> TestParser Module
+parseTestModule absPath = do
moduleName <- choice
[ label "module declaration" $ do
wsymbol "module"
+ off <- stateOffset <$> getParserState
x <- identifier
- (x:) <$> many (symbol "." >> identifier)
+ name <- (x:) <$> many (symbol "." >> identifier)
+ when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do
+ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "module name does not match file path"
+ eol >> scn
+ return name
, do
- return $ [ defaultName ]
+ return $ [ T.pack $ takeBaseName absPath ]
]
moduleTests <- many parseTestDefinition
eof
@@ -45,11 +53,11 @@ parseTestModule defaultName = do
parseTestFile :: FilePath -> IO Module
parseTestFile path = do
content <- TL.readFile path
+ absPath <- makeAbsolute path
let initState = TestParserState
{ testVars = []
, testContext = SomeExpr RootNetwork
}
- defaultModuleName = T.pack $ takeBaseName path
- case evalState (runParserT (parseTestModule defaultModuleName) path content) initState of
+ case evalState (runParserT (parseTestModule absPath) path content) initState of
Left err -> putStr (errorBundlePretty err) >> exitFailure
- Right tests -> return tests
+ Right testModule -> return testModule