w.i.p

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)

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 
+pathInfoPath :: Lens' PathInfoTopModule (Path Rel File)
+pathInfoPath = pathInfoTopModule . topModulePathToRelativePath'

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

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 ::

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)

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

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 =