Append unique hash to the pre-release tag in the Package.juvix version (

#3215) - Fixes #2985 - Fixes #3154 This pr fixes the above issues by appending the hash of all project files in the package version. In particular, it appends the hash to the pre-release tag. Also, when recursing in an import, we properly update the PackageId in the Entrypoint. --------- Co-authored-by: Lukasz Czajka <[email protected]>
anoma · Dec 6, 2024 · 3700386 · 3700386
1 parent bb8211b
commit 3700386
Show file tree

Hide file tree

Showing 36 changed files with 412 additions and 145 deletions.
diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs
@@ -1,8 +1,12 @@
 module Juvix.Compiler.Concrete.Data.Name where
 
 import Data.List.NonEmpty.Extra qualified as NonEmpty
+import Juvix.Data.Fixity
+import Juvix.Data.Loc
+import Juvix.Data.TopModulePathKey
+import Juvix.Data.WithLoc
 import Juvix.Extra.Serialize
-import Juvix.Prelude
+import Juvix.Prelude.Base
 import Juvix.Prelude.Pretty as Pretty
 
 type Symbol = WithLoc Text

diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed.hs
@@ -10,7 +10,6 @@ import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context
 import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
-import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Compiler.Store.Extra
 import Juvix.Compiler.Store.Language
 import Juvix.Prelude

diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs
@@ -24,7 +24,6 @@ import Juvix.Compiler.Concrete.Pretty (ppTrace)
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Data.Context
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
 import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parser
-import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Compiler.Store.Scoped.Language as Store
 import Juvix.Data.FixityInfo qualified as FI
 import Juvix.Prelude
@@ -956,12 +955,11 @@ checkFixityInfo ParsedFixityInfo {..} = do
 
 getModuleId :: forall r. (Member (Reader PackageId) r) => TopModulePathKey -> Sem r ModuleId
 getModuleId path = do
-  pkg <- ask
+  pkgId <- ask
   return
     ModuleId
       { _moduleIdPath = path,
-        _moduleIdPackage = pkg ^. packageIdName,
-        _moduleIdPackageVersion = show (pkg ^. packageIdVersion)
+        _moduleIdPackageId = pkgId
       }
 
 checkFixitySyntaxDef ::

diff --git a/src/Juvix/Compiler/Core/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Core/Data/InfoTable/Base.hs
@@ -2,7 +2,6 @@ module Juvix.Compiler.Core.Data.InfoTable.Base where
 
 import Juvix.Compiler.Concrete.Data.Builtins
 import Juvix.Compiler.Core.Language.Base
-import Juvix.Extra.Serialize
 
 data InfoTable' n = InfoTable
   { _identContext :: HashMap Symbol n,

diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs
@@ -6,6 +6,7 @@ where
 
 import Juvix.Compiler.Core.Data.InfoTable
 import Juvix.Compiler.Core.Language
+import Juvix.Compiler.Core.Pretty
 
 data Module = Module
   { _moduleId :: ModuleId,
@@ -64,17 +65,20 @@ lookupSpecialisationInfo Module {..} sym =
     lookupTabSpecialisationInfo' _moduleInfoTable sym
       <|> lookupTabSpecialisationInfo' _moduleImportsTable sym
 
+impossibleSymbolNotFound :: Symbol -> a
+impossibleSymbolNotFound sym = impossibleError ("Could not find symbol " <> ppTrace sym)
+
 lookupInductiveInfo :: Module -> Symbol -> InductiveInfo
-lookupInductiveInfo m sym = fromJust $ lookupInductiveInfo' m sym
+lookupInductiveInfo m sym = fromMaybe (impossibleSymbolNotFound sym) (lookupInductiveInfo' m sym)
 
 lookupConstructorInfo :: Module -> Tag -> ConstructorInfo
-lookupConstructorInfo m tag = fromJust $ lookupConstructorInfo' m tag
+lookupConstructorInfo m tag = fromJust (lookupConstructorInfo' m tag)
 
 lookupIdentifierInfo :: Module -> Symbol -> IdentifierInfo
-lookupIdentifierInfo m sym = fromJust $ lookupIdentifierInfo' m sym
+lookupIdentifierInfo m sym = fromMaybe (impossibleSymbolNotFound sym) (lookupIdentifierInfo' m sym)
 
 lookupIdentifierNode :: Module -> Symbol -> Node
-lookupIdentifierNode m sym = fromJust $ lookupIdentifierNode' m sym
+lookupIdentifierNode m sym = fromMaybe (impossibleSymbolNotFound sym) (lookupIdentifierNode' m sym)
 
 lookupBuiltinInductive :: Module -> BuiltinInductive -> Maybe InductiveInfo
 lookupBuiltinInductive Module {..} b =

diff --git a/src/Juvix/Compiler/Core/Language/Primitives.hs b/src/Juvix/Compiler/Core/Language/Primitives.hs
@@ -7,7 +7,6 @@ represented by booleans, any type isomorphic to unary natural numbers may be
 represented by integers with minimum value 0. -}
 
 import Juvix.Compiler.Core.Language.Base
-import Juvix.Extra.Serialize
 
 -- | Primitive type representation.
 data Primitive

diff --git a/src/Juvix/Compiler/Core/Pretty/Base.hs b/src/Juvix/Compiler/Core/Pretty/Base.hs
@@ -100,6 +100,12 @@ instance PrettyCode Tag where
     BuiltinTag tag -> ppCode tag
     UserTag (TagUser mid tag) -> return $ kwUnnamedConstr <> pretty tag <> "@" <> pretty mid
 
+instance PrettyCode ModuleId where
+  ppCode = return . pretty
+
+instance PrettyCode Symbol where
+  ppCode = return . pretty
+
 instance PrettyCode Primitive where
   ppCode = \case
     p@(PrimInteger _) | p == primitiveUInt8 -> return $ annotate (AnnKind KNameInductive) (pretty ("UInt8" :: String))
@@ -568,7 +574,7 @@ instance PrettyCode InfoTable where
   ppCode :: forall r. (Member (Reader Options) r) => InfoTable -> Sem r (Doc Ann)
   ppCode tbl = do
     let header x = annotate AnnImportant (Str.commentLineStart <+> x) <> line
-    tys <- ppInductives (toList (tbl ^. infoInductives))
+    tys <- ppInductives (sortOn (^. inductiveSymbol) $ toList (tbl ^. infoInductives))
     sigs <- ppSigs (sortOn (^. identifierSymbol) $ toList (tbl ^. infoIdentifiers))
     ctx' <- ppContext (tbl ^. identContext)
     axioms <- vsep <$> mapM ppCode (tbl ^. infoAxioms)

diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs
@@ -274,7 +274,7 @@ processModuleCacheMiss entryIx = do
       return r
     ProcessModuleRecompile recomp -> recomp ^. recompileDo
 
-processProject :: (Members '[ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => Sem r [(ImportNode, PipelineResult ModuleInfo)]
+processProject :: (Members '[PathResolver, ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => Sem r [(ImportNode, PipelineResult ModuleInfo)]
 processProject = do
   rootDir <- asks (^. entryPointRoot)
   nodes <- toList <$> asks (importTreeProjectNodes rootDir)
@@ -312,10 +312,13 @@ processRecursiveUpToTyped = do
   where
     goImport :: ImportNode -> Sem r InternalTypedResult
     goImport node = do
+      pkgInfo <- fromJust . HashMap.lookup (node ^. importNodePackageRoot) <$> getPackageInfos
+      let pid = pkgInfo ^. packageInfoPackageId
       entry <- ask
       let entry' =
             entry
               { _entryPointStdin = Nothing,
+                _entryPointPackageId = pid,
                 _entryPointModulePath = Just (node ^. importNodeAbsFile)
               }
       (^. pipelineResult) <$> runReader entry' (processFileUpTo upToInternalTyped)

diff --git a/src/Juvix/Compiler/Pipeline/DriverParallel.hs b/src/Juvix/Compiler/Pipeline/DriverParallel.hs
@@ -33,7 +33,7 @@ type Node = EntryIndex
 
 mkNodesIndex ::
   forall r.
-  (Members '[Reader EntryPoint] r) =>
+  (Members '[PathResolver, Reader EntryPoint] r) =>
   ImportTree ->
   Sem r (NodesIndex ImportNode Node)
 mkNodesIndex tree =

diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs
@@ -10,11 +10,16 @@ module Juvix.Compiler.Pipeline.Loader.PathResolver
     runPathResolverPipe',
     evalPathResolverPipe,
     findPackageJuvixFiles,
+    importNodePackageId,
+    mkPackageInfoPackageId,
+    checkConflicts,
   )
 where
 
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashSet qualified as HashSet
+import Data.List.NonEmpty.Extra qualified as NonEmpty
+import Data.Versions qualified as Ver
 import Juvix.Compiler.Concrete.Data.Name
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
 import Juvix.Compiler.Concrete.Translation.ImportScanner
@@ -36,6 +41,23 @@ import Juvix.Extra.Paths
 import Juvix.Extra.Stdlib (ensureStdlib)
 import Juvix.Prelude
 
+checkConflicts :: forall r'. (Members '[Error JuvixError] r') => [PackageInfo] -> Sem r' ()
+checkConflicts pkgs = do
+  let reps = findRepeatedOn (^. packageInfoPackageId) pkgs
+  case nonEmpty reps of
+    Just (rep :| _) -> errRep rep
+    Nothing -> return ()
+  where
+    errRep :: (NonEmpty PackageInfo, PackageId) -> Sem r' ()
+    errRep (l, pid) =
+      throw
+        . JuvixError
+        $ ErrAmbiguousPackageId
+          AmbiguousPackageId
+            { _ambiguousPackageId = pid,
+              _ambiguousPackageIdPackages = l
+            }
+
 mkPackage ::
   forall r.
   (Members '[Files, Error JuvixError, Reader ResolverEnv, DependencyResolver, EvalFileEff] r) =>
@@ -55,6 +77,35 @@ findPackageJuvixFiles pkgRoot = map (fromJust . stripProperPrefix pkgRoot) <$> w
         newJuvixFiles :: [Path Abs File]
         newJuvixFiles = [cd <//> f | f <- files, isJuvixOrJuvixMdFile f, not (isPackageFile f)]
 
+-- | Append the hash of all files in the project to the pre-release
+mkPackageInfoPackageId :: (Members '[Files] r) => Path Abs Dir -> [Path Rel File] -> PackageLike -> Sem r PackageId
+mkPackageInfoPackageId root pkgRelFiles pkgLike = do
+  let pkgDotJuvix = mkPackageFilePath root
+  pkgDotJuvixExists <- fileExists' pkgDotJuvix
+  let pkgJuvixFiles = [root <//> rFile | rFile <- pkgRelFiles]
+  let baseVersion = packageLikeVersion pkgLike
+      allFiles
+        | pkgDotJuvixExists = pkgDotJuvix : pkgJuvixFiles
+        | otherwise = pkgJuvixFiles
+  filesHash <- SHA256.digestFiles allFiles
+  let version = case Ver._svPreRel baseVersion of
+        Nothing ->
+          baseVersion {_svPreRel = Just (Ver.Release (pure (Ver.Alphanum filesHash)))}
+        Just (Ver.Release r) -> baseVersion {_svPreRel = Just (Ver.Release (NonEmpty.snoc r (Ver.Alphanum filesHash)))}
+  return
+    PackageId
+      { _packageIdName = pkgLike ^. packageLikeName,
+        _packageIdVersion = version
+      }
+  where
+    packageLikeVersion :: PackageLike -> SemVer
+    packageLikeVersion = \case
+      PackageReal pkg -> pkg ^. packageVersion
+      PackageStdlibInGlobalPackage -> defaultVersion
+      PackageBase {} -> defaultVersion
+      PackageType {} -> defaultVersion
+      PackageDotJuvix {} -> defaultVersion
+
 mkPackageInfo ::
   forall r.
   (Members '[TaggedLock, Files, Error JuvixError, Error DependencyError, Reader ResolverEnv, DependencyResolver] r) =>
@@ -78,6 +129,7 @@ mkPackageInfo mpackageEntry _packageRoot pkg = do
             : globalPackageBaseAbsDir
             : _packageRoot
             : depsPaths
+  _packageInfoPackageId <- mkPackageInfoPackageId _packageRoot (toList _packageJuvixRelativeFiles) _packagePackage
   return PackageInfo {..}
   where
     pkgFile :: Path Abs File
@@ -117,17 +169,16 @@ mkPackageInfo mpackageEntry _packageRoot pkg = do
             checkDep d =
               unless
                 (mkName d `HashSet.member` lockfileDepNames)
-                ( throw
-                    DependencyError
-                      { _dependencyErrorPackageFile = pkgFile,
-                        _dependencyErrorCause =
-                          MissingLockfileDependencyError
-                            MissingLockfileDependency
-                              { _missingLockfileDependencyDependency = d,
-                                _missingLockfileDependencyPath = lf ^. lockfileInfoPath
-                              }
-                      }
-                )
+                $ throw
+                  DependencyError
+                    { _dependencyErrorPackageFile = pkgFile,
+                      _dependencyErrorCause =
+                        MissingLockfileDependencyError
+                          MissingLockfileDependency
+                            { _missingLockfileDependencyDependency = d,
+                              _missingLockfileDependencyPath = lf ^. lockfileInfoPath
+                            }
+                    }
 
 lookupCachedDependency :: (Members '[State ResolverState, Reader ResolverEnv, Files, DependencyResolver] r) => Path Abs Dir -> Sem r (Maybe LockfileDependency)
 lookupCachedDependency p = fmap (^. resolverCacheItemDependency) . HashMap.lookup p <$> gets (^. resolverCache)
@@ -140,12 +191,14 @@ registerPackageBase = do
   packageBaseAbsDir <- globalPackageBaseRoot
   runReader packageBaseAbsDir updatePackageBaseFiles
   packageBaseRelFiles <- relFiles packageBaseAbsDir
+  _packageInfoPackageId <- mkPackageInfoPackageId packageBaseAbsDir (toList packageBaseRelFiles) PackageBase
   let pkgInfo =
         PackageInfo
           { _packageRoot = packageBaseAbsDir,
             _packageJuvixRelativeFiles = packageBaseRelFiles,
             _packagePackage = PackageBase,
-            _packageAvailableRoots = HashSet.singleton packageBaseAbsDir
+            _packageAvailableRoots = HashSet.singleton packageBaseAbsDir,
+            _packageInfoPackageId
           }
       dep =
         LockfileDependency
@@ -169,27 +222,30 @@ registerDependencies' conf = do
   initialized <- gets (^. resolverInitialized)
   unless initialized $ do
     modify (set resolverInitialized True)
-    e <- ask @EntryPoint
+    registerDepsFromRoot
     mapError (JuvixError @ParserError) registerPackageBase
-    case e ^. entryPointPackageType of
-      GlobalStdlib -> do
-        glob <- globalRoot
-        void (addRootDependency conf e glob)
-      GlobalPackageBase -> return ()
-      GlobalPackageDescription -> void (addRootDependency conf e (e ^. entryPointRoot))
-      LocalPackage -> do
-        lockfile <- addRootDependency conf e (e ^. entryPointRoot)
-        whenM shouldWriteLockfile $ do
-          let root :: Path Abs Dir = e ^. entryPointSomeRoot . someRootDir
-          packagePath :: Path Abs File <- do
-            let packageDotJuvix = mkPackagePath root
-                juvixDotYaml = mkPackageFilePath root
-            x <- findM fileExists' [packageDotJuvix, juvixDotYaml]
-            return (fromMaybe (error ("No package file found in " <> show root)) x)
-          packageFileChecksum <- SHA256.digestFile packagePath
-          lockfilePath' <- lockfilePath
-          writeLockfile lockfilePath' packageFileChecksum lockfile
   where
+    registerDepsFromRoot = do
+      e <- ask
+      case e ^. entryPointPackageType of
+        GlobalStdlib -> do
+          glob <- globalRoot
+          void (addRootDependency conf e glob)
+        GlobalPackageBase -> return ()
+        GlobalPackageDescription -> void (addRootDependency conf e (e ^. entryPointRoot))
+        LocalPackage -> do
+          lockfile <- addRootDependency conf e (e ^. entryPointRoot)
+          whenM shouldWriteLockfile $ do
+            let root :: Path Abs Dir = e ^. entryPointSomeRoot . someRootDir
+            packagePath :: Path Abs File <- do
+              let packageDotJuvix = mkPackagePath root
+                  juvixDotYaml = mkPackageFilePath root
+              x <- findM fileExists' [packageDotJuvix, juvixDotYaml]
+              return (fromMaybe (error ("No package file found in " <> show root)) x)
+            packageFileChecksum <- SHA256.digestFile packagePath
+            lockfilePath' <- lockfilePath
+            writeLockfile lockfilePath' packageFileChecksum lockfile
+
     shouldWriteLockfile :: Sem r Bool
     shouldWriteLockfile = do
       lockfileExists <- lockfilePath >>= fileExists'
@@ -268,7 +324,7 @@ addDependency' pkg me resolvedDependency = do
   selectPackageLockfile pkg $ do
     pkgInfo <- mkPackageInfo me (resolvedDependency ^. resolvedDependencyPath) pkg
     addPackageRelativeFiles pkgInfo
-    let packagePath = pkgInfo ^. packagePackage . packageLikeFile
+    let packagePath = packageLikeFile (pkgInfo ^. packagePackage)
     subDeps <-
       forM
         (pkgInfo ^. packagePackage . packageLikeDependencies)
@@ -365,6 +421,10 @@ isModuleOrphan topJuvixPath = do
         && not (pathPackageBase `isProperPrefixOf` actualPath)
     )
 
+importNodePackageId :: (Members '[PathResolver] r) => ImportNode -> Sem r PackageId
+importNodePackageId n =
+  (^?! at (n ^. importNodePackageRoot) . _Just . packageInfoPackageId) <$> getPackageInfos
+
 expectedPath' ::
   (Members '[Reader ResolverEnv, Files] r) =>
   TopModulePath ->
@@ -409,7 +469,11 @@ runPathResolver2 st topEnv arg = do
       )
       handler
     )
-    arg
+    $ do
+      _pkgs <- toList <$> getPackageInfos
+      -- I think we should not check for conflicts
+      -- checkConflicts pkgs
+      arg
   where
     handler ::
       forall t localEs x.