diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs index ef380916d0..cd094db57d 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs @@ -304,18 +304,19 @@ resolvePath' mp = do } ) -expectedPath' :: (Members '[Reader ResolverEnv] r) - => Path Abs File -> TopModulePath -> Sem r (Path Abs File) -expectedPath' actualPath m = do - root <- asks (^. envRoot) - traceM $ "expected root" <> show root +expectedPath' :: + (Members '[Reader ResolverEnv] r) => + TopModulePath -> + Sem r PathInfoTopModule +expectedPath' m = do msingle <- asks (^. envSingleFile) - traceM $ "expected single" <> show msingle - let tp = topModulePathToRelativePath' m - traceM $ "expected topModpath" <> show tp - if - | msingle == Just actualPath -> return actualPath - | otherwise -> return (root tp) + let _pathInfoTopModule = m + _rootInfoPath <- asks (^. envRoot) + let _rootInfoKind = case msingle of + Just _ -> RootKindGlobalPackage + Nothing -> RootKindLocalPackage + _pathInfoRootInfo = Just RootInfo {..} + return PathInfoTopModule {..} re :: forall r a. @@ -330,7 +331,7 @@ re = reinterpret2H helper Tactical PathResolver (Sem rInitial) (Reader ResolverEnv ': (State ResolverState ': r)) x helper = \case RegisterDependencies forceUpdateLockfile -> registerDependencies' forceUpdateLockfile >>= pureT - ExpectedModulePath a m -> expectedPath' a m >>= pureT + ExpectedPathInfoTopModule m -> expectedPath' m >>= pureT WithPath m a -> do x :: Either PathResolverError (Path Abs Dir, Path Rel File) <- resolvePath' m oldroot <- asks (^. envRoot) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs index 547e34c46b..60bbaa67f1 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Base.hs @@ -7,42 +7,40 @@ where import Juvix.Compiler.Concrete.Data.Name import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.DependenciesConfig import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error +import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Paths import Juvix.Prelude -data Root = - RootGlobalStdlib - | RootGlobalPackage - | RootLocalPackage - deriving stock (Show, Eq, Ord) +data RootKind + = RootKindGlobalStdlib + | RootKindGlobalPackage + | RootKindLocalPackage + deriving stock (Show, Eq, Ord) -data PackageRoot = PackageRoot - { _packageRoot :: Path Abs Dir, - _packageRootType :: Root +data RootInfo = RootInfo + { _rootInfoPath :: Path Abs Dir, + _rootInfoKind :: RootKind } deriving stock (Show, Eq, Ord) data PathInfoTopModule = PathInfoTopModule { _pathInfoTopModule :: TopModulePath, - _pathInfoPackageRoot :: Maybe PackageRoot, - _pathInfoRelPath :: Path Rel File, - _pathInfoFileExt :: FileExt + _pathInfoRootInfo :: Maybe RootInfo } + data PathResolver m a where RegisterDependencies :: DependenciesConfig -> PathResolver m () - ExpectedModulePath :: Path Abs File -> TopModulePath - -> PathResolver m (Maybe PathInfoTopModule) + ExpectedPathInfoTopModule :: TopModulePath -> PathResolver m PathInfoTopModule WithPath :: TopModulePath -> (Either PathResolverError (Path Abs Dir, Path Rel File) -> m x) -> PathResolver m x -makeLenses ''PackageRoot +makeLenses ''RootInfo makeLenses ''PathInfoTopModule makeSem ''PathResolver withPathFile :: (Members '[PathResolver] r) => TopModulePath -> (Either PathResolverError (Path Abs File) -> Sem r a) -> Sem r a withPathFile m f = withPath m (f . mapRight (uncurry ())) -pathInfoAbsPath :: Lens' PathInfoTopModule (Path Abs File) -pathInfoAbsPath = impossible --- pathInfoPackageRoot . packageRoot . to () . pathInfoRelPath \ No newline at end of file +pathInfoPath :: Lens' PathInfoTopModule (Path Rel File) +pathInfoPath = pathInfoTopModule . topModulePathToRelativePath' diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs index d2201ab062..21970ecde5 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver/Paths.hs @@ -4,8 +4,10 @@ import Juvix.Compiler.Concrete.Data.Name import Juvix.Prelude topModulePathToRelativePath' :: TopModulePath -> Path Rel File -topModulePathToRelativePath' = - topModulePathToRelativePath (show FileExtJuvix) "" () +topModulePathToRelativePath' m = + let absPath :: Path Abs File = getLoc m ^. intervalFile + ext = fileExtension' absPath + in topModulePathToRelativePath ext "" () m topModulePathToRelativePath :: String -> String -> (FilePath -> FilePath -> FilePath) -> TopModulePath -> Path Rel File topModulePathToRelativePath ext suffix joinpath mp = relFile relFilePath diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index bfd9be513d..d70b7c6550 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -283,24 +283,26 @@ topModuleDefStdin = do top moduleDef -- FIX: https://github.com/anoma/juvix/pull/251 -checkPath :: +checkModulePath :: (Members '[PathResolver, Error ParserError] s) => - Maybe (Path Abs File) -> - TopModulePath -> + Module 'Parsed 'ModuleTop -> Sem s () -checkPath maybePath path = do - let actualPath = fromMaybe (getLoc path ^. intervalFile) maybePath - mexpectedPath <- expectedModulePath actualPath path - whenJust mexpectedPath $ \expectedPath -> - unlessM (equalPaths expectedPath actualPath) $ - throw - ( ErrWrongTopModuleName - WrongTopModuleName - { _wrongTopModuleNameActualName = path, - _wrongTopModuleNameExpectedPath = expectedPath, - _wrongTopModuleNameActualPath = actualPath - } - ) +checkModulePath m = do + let topJuvixPath :: TopModulePath = m ^. modulePath + pathInfo :: PathInfoTopModule <- expectedPathInfoTopModule topJuvixPath + whenJust (pathInfo ^. pathInfoRootInfo) $ + \expectedRootInfo -> do + let expectedAbsPath = (expectedPackageRoot ^. rootInfoPath) (pathInfo ^. pathInfoRelPath) + actualPath = getLoc topJuvixPath ^. intervalFile + unlessM (equalPaths actualPath expectedAbsPath) $ + throw + ( ErrWrongTopModuleName + WrongTopModuleName + { _wrongTopModuleNameActualName = topJuvixPath, + _wrongTopModuleNameExpectedPath = expectedAbsPath, + _wrongTopModuleNameActualPath = actualPath + } + ) topModuleDef :: (Members '[Error ParserError, Files, PathResolver, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => @@ -309,7 +311,7 @@ topModuleDef = do space >> optional_ stashJudoc optional_ stashPragmas m <- top moduleDef - P.lift (checkPath Nothing (m ^. modulePath)) + P.lift (checkModulePath m) return m juvixCodeBlockParser :: diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs index adb793aca0..9a9ef25023 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs @@ -11,8 +11,6 @@ import Juvix.Extra.PackageFiles import Juvix.Extra.Paths import Juvix.Extra.Stdlib - - -- | A PackageResolver interpreter intended to be used to load a Package file. -- It aggregates files at `rootPath` and files from the global package stdlib. runPackagePathResolver :: forall r a. (Members '[Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a @@ -22,41 +20,43 @@ runPackagePathResolver rootPath sem = do runReader globalStdlib updateStdlib runReader globalPackageDir updatePackageFiles packageFiles' <- relFiles globalPackageDir - let mkPackageRoot' = mkPackageRoot packageFiles' globalPackageDir globalStdlib + let mkRootInfo' = mkRootInfo packageFiles' globalPackageDir globalStdlib ( interpretH $ \case RegisterDependencies {} -> pureT () - ExpectedModulePath t m -> do - let _pathInfoRelPath = topModulePathToRelativePath' m - _pathInfoTopModule = m ^. topModulePath - _pathInfoPackageRoot = mkPackageRoot' _pathInfoRelPath - pureT . Just $ PathInfoTopModule {..} + ExpectedPathInfoTopModule m -> do + let _pathInfoTopModule = m + _pathInfoRootInfo = mkRootInfo' (topModulePathToRelativePath' m) + pureT PathInfoTopModule {..} WithPath m a -> do let relPath = topModulePathToRelativePath' m x :: Either PathResolverError (Path Abs Dir, Path Rel File) - x = case mkPackageRoot' relPath of - Just p -> Right (p ^. packageRoot, relPath) + x = case mkRootInfo' relPath of + Just p -> Right (p ^. rootInfoPath, relPath) Nothing -> Left (ErrPackageInvalidImport PackageInvalidImport {_packageInvalidImport = m}) runTSimple (return x) >>= bindTSimple a ) sem where - mkPackageRoot :: HashSet (Path Rel File) -> Path Abs Dir -> Path Abs Dir -> Path Rel File -> Maybe PackageRoot - mkPackageRoot pkgFiles globalPackageDir globalStdlib relPath + mkRootInfo :: HashSet (Path Rel File) -> Path Abs Dir -> Path Abs Dir -> Path Rel File -> Maybe RootInfo + mkRootInfo pkgFiles globalPackageDir globalStdlib relPath | parent preludePath `isProperPrefixOf` relPath = - Just $ PackageRoot { - _packageRoot = globalStdlib, - _packageRootType = RootGlobalStdlib - } + Just $ + RootInfo + { _rootInfoPath = globalStdlib, + _rootInfoKind = RootKindGlobalStdlib + } | relPath `HashSet.member` pkgFiles = - Just $ PackageRoot { - _packageRoot = globalPackageDir, - _packageRootType = RootGlobalPackage - } - | relPath == packageFilePath = - Just $ PackageRoot { - _packageRoot = rootPath, - _packageRootType = RootLocalPackage - } + Just $ + RootInfo + { _rootInfoPath = globalPackageDir, + _rootInfoKind = RootKindGlobalPackage + } + | relPath == packageFilePath = + Just $ + RootInfo + { _rootInfoPath = rootPath, + _rootInfoKind = RootKindLocalPackage + } | otherwise = Nothing runPackagePathResolver' :: (Members '[Files] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a) diff --git a/src/Juvix/Data/FileExt.hs b/src/Juvix/Data/FileExt.hs index a5ac3840b2..4fbb8bc041 100644 --- a/src/Juvix/Data/FileExt.hs +++ b/src/Juvix/Data/FileExt.hs @@ -149,3 +149,26 @@ isHtmlFile = (== Just htmlFileExt) . fileExtension isCssFile :: Path b File -> Bool isCssFile = (== Just cssFileExt) . fileExtension + +toFileExt :: Path b File -> Maybe FileExt +toFileExt p + | isJuvixFile p = Just FileExtJuvix + | isJuvixMarkdownFile p = Just FileExtJuvixMarkdown + | isJuvixGebFile p = Just FileExtJuvixGeb + | isJuvixCoreFile p = Just FileExtJuvixCore + | isJuvixAsmFile p = Just FileExtJuvixAsm + | isVampIRFile p = Just FileExtVampIR + | isVampIRParamsFile p = Just FileExtVampIRParams + | isPlonkFile p = Just FileExtPlonk + | isHaloFile p = Just FileExtHalo + | isLispFile p = Just FileExtLisp + | isCFile p = Just FileExtC + | isMarkdownFile p = Just FileExtMarkdown + | isHtmlFile p = Just FileExtHtml + | isCssFile p = Just FileExtCss + | otherwise = Nothing + +fileExtension' :: Path b File -> String +fileExtension' p = case toFileExt p of + Just ext -> Text.unpack $ fileExtToText ext + Nothing -> mconcat $ fileExtension p diff --git a/test/Parsing/Negative.hs b/test/Parsing/Negative.hs index ae250d5773..e31d974327 100644 --- a/test/Parsing/Negative.hs +++ b/test/Parsing/Negative.hs @@ -43,15 +43,15 @@ wrongError = Just "Incorrect error" negTest :: String -> Path Rel Dir -> Path Rel File -> (ParserError -> Maybe FailMsg) -> NegTest negTest _name d f _checkErr = negTestAbsDir _name (root d) f _checkErr - + negTestAbsDir :: String -> Path Abs Dir -> Path Rel File -> (ParserError -> Maybe FailMsg) -> NegTest negTestAbsDir _name _dir f _checkErr = - NegTest - { _file = _dir f, - _dir, - _name, - _checkErr - } + NegTest + { _file = _dir f, + _dir, + _name, + _checkErr + } parserErrorTests :: [NegTest] parserErrorTests =