From 37003867c869cf4fc8b2bdb1b852f93403dba7fd Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 6 Dec 2024 09:29:57 +0100 Subject: [PATCH] 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 --- src/Juvix/Compiler/Concrete/Data/Name.hs | 6 +- .../Concrete/Translation/FromParsed.hs | 1 - .../FromParsed/Analysis/Scoping.hs | 6 +- .../Compiler/Core/Data/InfoTable/Base.hs | 1 - src/Juvix/Compiler/Core/Data/Module.hs | 12 +- .../Compiler/Core/Language/Primitives.hs | 1 - src/Juvix/Compiler/Core/Pretty/Base.hs | 8 +- src/Juvix/Compiler/Pipeline/Driver.hs | 5 +- src/Juvix/Compiler/Pipeline/DriverParallel.hs | 2 +- .../Compiler/Pipeline/Loader/PathResolver.hs | 130 +++++++++++++----- .../Pipeline/Loader/PathResolver/Error.hs | 25 ++++ .../Loader/PathResolver/PackageInfo.hs | 38 +++-- .../Compiler/Pipeline/ModuleInfoCache.hs | 6 +- src/Juvix/Compiler/Pipeline/Package/Base.hs | 18 --- .../Pipeline/Package/Loader/PathResolver.hs | 33 +++-- src/Juvix/Compiler/Pipeline/Repl.hs | 4 +- src/Juvix/Compiler/Store/Core/Language.hs | 5 +- src/Juvix/Data.hs | 2 + src/Juvix/Data/CodeAnn.hs | 13 +- src/Juvix/Data/Loc.hs | 3 + src/Juvix/Data/ModuleId.hs | 11 +- src/Juvix/Data/NameKind.hs | 2 +- src/Juvix/Data/PackageId.hs | 28 ++++ src/Juvix/Data/SHA256.hs | 53 ++++++- src/Juvix/Extra/Serialize.hs | 7 - src/Juvix/Prelude/Base.hs | 41 ++++++ src/Juvix/Prelude/Base/Foundation.hs | 47 ++++--- src/Juvix/Prelude/Effects/Base.hs | 8 ++ src/Juvix/Prelude/Effects/Input.hs | 2 +- src/Parallel/ProgressLog.hs | 9 +- tests/negative/AmbiguousPackageId/Main.juvix | 1 + .../negative/AmbiguousPackageId/Package.juvix | 9 ++ .../AmbiguousPackageId/dep1/Package.juvix | 9 ++ .../AmbiguousPackageId/dep1/main.juvix | 1 + .../AmbiguousPackageId/dep2/Package.juvix | 9 ++ .../AmbiguousPackageId/dep2/main.juvix | 1 + 36 files changed, 412 insertions(+), 145 deletions(-) create mode 100644 src/Juvix/Data/PackageId.hs create mode 100644 tests/negative/AmbiguousPackageId/Main.juvix create mode 100644 tests/negative/AmbiguousPackageId/Package.juvix create mode 100644 tests/negative/AmbiguousPackageId/dep1/Package.juvix create mode 100644 tests/negative/AmbiguousPackageId/dep1/main.juvix create mode 100644 tests/negative/AmbiguousPackageId/dep2/Package.juvix create mode 100644 tests/negative/AmbiguousPackageId/dep2/main.juvix diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs index 98346fc14b..8b9f4c6d88 100644 --- 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 index beae4e8189..0c73734a88 100644 --- 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 index 006144e12a..a0eed183eb 100644 --- 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 index 9773f8ae08..83cdc8a173 100644 --- 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 index 6c3baee651..fead44a112 100644 --- 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 index 19fb5ba6a5..3cbd68d55c 100644 --- 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 index 57af9cb552..e602a4e09f 100644 --- 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 index 3fcb3a508e..7bdb65907a 100644 --- 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 index c06aa10930..395856a6bf 100644 --- 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 index 8f0b8cb5c3..39f7018b0c 100644 --- 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. diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs index 6d84e401b8..f0c0248c1c 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Error.hs @@ -5,6 +5,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo import Juvix.Compiler.Pipeline.Package.Base import Juvix.Data.CodeAnn import Juvix.Data.Effect.Git +import Juvix.Extra.Paths.Base import Juvix.Prelude data DependencyErrorGit = DependencyErrorGit @@ -93,6 +94,9 @@ data PathResolverError = ErrDependencyConflict DependencyConflict | ErrMissingModule MissingModule | ErrPackageInvalidImport PackageInvalidImport + | -- | The ErrAmbiguousPackageId error is unused at the moment. We append the + -- hash of all project files to the pre-release tag of the package version. + ErrAmbiguousPackageId AmbiguousPackageId deriving stock (Show) instance ToGenericError PathResolverError where @@ -114,12 +118,14 @@ instance HasLoc PathResolverError where getLoc _missingModule ErrPackageInvalidImport PackageInvalidImport {..} -> getLoc _packageInvalidImport + ErrAmbiguousPackageId a -> getLoc a instance PrettyCodeAnn PathResolverError where ppCodeAnn = \case ErrDependencyConflict e -> ppCodeAnn e ErrMissingModule e -> ppCodeAnn e ErrPackageInvalidImport e -> ppCodeAnn e + ErrAmbiguousPackageId e -> ppCodeAnn e data DependencyConflict = DependencyConflict { _conflictPackages :: NonEmpty PackageInfo, @@ -184,3 +190,22 @@ instance PrettyCodeAnn PackageInvalidImport where <+> "cannot be imported by the Package file." <> line <> "Package files may only import modules from the Juvix standard library, Juvix.Builtin modules, or from the PackageDescription module." + +data AmbiguousPackageId = AmbiguousPackageId + { _ambiguousPackageId :: PackageId, + _ambiguousPackageIdPackages :: NonEmpty PackageInfo + } + deriving stock (Show) + +instance HasLoc AmbiguousPackageId where + getLoc AmbiguousPackageId {..} = intervalFromFile ((head _ambiguousPackageIdPackages) ^. packageRoot packageFilePath) + +instance PrettyCodeAnn AmbiguousPackageId where + ppCodeAnn AmbiguousPackageId {..} = do + "Ambiguous package id:" + <> line + <> ppCodeAnn _ambiguousPackageId + <> line + <> "The above package id is the same for the following packages" + <> line + <> itemize ((pretty . (^. packageRoot)) <$> _ambiguousPackageIdPackages) diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs index 3d2a785baa..9903c9cc0c 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/PackageInfo.hs @@ -14,7 +14,7 @@ import Juvix.Prelude data PackageLike = PackageReal Package - | PackageGlobalStdlib + | PackageStdlibInGlobalPackage | PackageBase | PackageType | PackageDotJuvix @@ -26,14 +26,16 @@ data PackageInfo = PackageInfo -- .juvix.md files. Note that it should not contain Package.juvix. _packageJuvixRelativeFiles :: HashSet (Path Rel File), _packageAvailableRoots :: HashSet (Path Abs Dir), + _packageInfoPackageId :: PackageId, _packagePackage :: PackageLike } deriving stock (Show) makeLenses ''PackageInfo +makePrisms ''PackageLike -packageFiles :: PackageInfo -> [Path Abs File] -packageFiles k = [k ^. packageRoot f | f <- toList (k ^. packageJuvixRelativeFiles)] +packageInfoFiles :: PackageInfo -> [Path Abs File] +packageInfoFiles k = [k ^. packageRoot f | f <- (toList (k ^. packageJuvixRelativeFiles))] -- | Does *not* include Package.juvix packageJuvixFiles :: SimpleGetter PackageInfo (HashSet (Path Rel File)) @@ -46,37 +48,31 @@ keepJuvixFiles = HashSet.filter isJuvixOrJuvixMdFile packageLikeName :: SimpleGetter PackageLike Text packageLikeName = to $ \case PackageReal r -> r ^. packageName - PackageGlobalStdlib -> "global-stdlib" + PackageStdlibInGlobalPackage {} -> "global-stdlib" PackageBase -> Str.packageBase PackageType -> "package-type" PackageDotJuvix -> "package-dot-juvix" --- | FIXME all PackageLike should have versions -packageLikeVersion :: SimpleGetter PackageLike (Maybe SemVer) -packageLikeVersion = to $ \case - PackageReal pkg -> Just (pkg ^. packageVersion) - PackageGlobalStdlib {} -> Nothing - PackageBase {} -> Nothing - PackageType {} -> Nothing - PackageDotJuvix {} -> Nothing - -packageLikeNameAndVersion :: SimpleGetter PackageLike (Doc CodeAnn) -packageLikeNameAndVersion = to $ \n -> - annotate AnnImportant (pretty (n ^. packageLikeName)) - <+?> (pretty . prettySemVer <$> n ^. packageLikeVersion) +packageInfoNameAndVersion :: + PackageInfo -> + Doc CodeAnn +packageInfoNameAndVersion n = + let pid = n ^. packageInfoPackageId + in annotate AnnImportant (pretty (pid ^. packageIdName)) + <+> pretty (prettySemVer (pid ^. packageIdVersion)) packageLikeDependencies :: SimpleGetter PackageLike [Dependency] packageLikeDependencies = to $ \case PackageReal r -> r ^. packageDependencies - PackageGlobalStdlib -> [] + PackageStdlibInGlobalPackage {} -> impossible PackageBase -> [] PackageType -> [] PackageDotJuvix -> [] -packageLikeFile :: SimpleGetter PackageLike (Path Abs File) -packageLikeFile = to $ \case +packageLikeFile :: PackageLike -> Path Abs File +packageLikeFile = \case PackageReal r -> r ^. packageFile - PackageGlobalStdlib -> impossible + PackageStdlibInGlobalPackage {} -> impossible PackageBase -> impossible PackageType -> impossible PackageDotJuvix -> impossible diff --git a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs index 3e5e1f2510..0340a41868 100644 --- a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs +++ b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Pipeline.ModuleInfoCache where import Juvix.Compiler.Pipeline.EntryPoint -import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.ImportNode +import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Result import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Effect.Cache @@ -28,9 +28,10 @@ entryIndexPath = fromMaybe err . (^. entryIxEntry . entryPointModulePath) err :: a err = error "unexpected: EntryIndex should always have a path" -mkEntryIndex :: (Members '[Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex +mkEntryIndex :: (Members '[PathResolver, Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex mkEntryIndex node = do entry <- ask + pkgId <- importNodePackageId node let path = node ^. importNodeAbsFile stdin' | Just path == entry ^. entryPointModulePath = entry ^. entryPointStdin @@ -38,6 +39,7 @@ mkEntryIndex node = do entry' = entry { _entryPointStdin = stdin', + _entryPointPackageId = pkgId, _entryPointModulePath = Just path } return diff --git a/src/Juvix/Compiler/Pipeline/Package/Base.hs b/src/Juvix/Compiler/Pipeline/Package/Base.hs index 4ea8bbea9c..1651152d2e 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Base.hs @@ -11,7 +11,6 @@ import Data.Versions hiding (Lens') import Juvix.Compiler.Pipeline.Lockfile import Juvix.Compiler.Pipeline.Package.Dependency import Juvix.Extra.Paths -import Juvix.Extra.Strings qualified as Str import Juvix.Prelude data BuildDir @@ -44,12 +43,6 @@ type family PackageLockfileType s = res | res -> s where PackageLockfileType 'Raw = Maybe () PackageLockfileType 'Processed = Maybe LockfileInfo -data PackageId = PackageId - { _packageIdName :: Text, - _packageIdVersion :: SemVer - } - deriving stock (Show, Eq) - data Package' (s :: IsProcessed) = Package { _packageName :: NameType s, _packageVersion :: VersionType s, @@ -62,7 +55,6 @@ data Package' (s :: IsProcessed) = Package deriving stock (Generic) makeLenses ''Package' -makeLenses ''PackageId type Package = Package' 'Processed @@ -159,9 +151,6 @@ rawPackage pkg = _packageLockfile = Nothing } -defaultVersion :: SemVer -defaultVersion = SemVer 0 0 0 Nothing Nothing - unsetPackageLockfile :: Package -> Package unsetPackageLockfile = set packageLockfile Nothing @@ -183,13 +172,6 @@ globalPackage p = _packageLockfile = Nothing } -packageBaseId :: PackageId -packageBaseId = - PackageId - { _packageIdName = Str.packageBase, - _packageIdVersion = defaultVersion - } - mkPackageFilePath :: Path Abs Dir -> Path Abs File mkPackageFilePath = ( juvixYamlFile) diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs index 9b71c9ba9c..015203c9f5 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs @@ -30,7 +30,7 @@ makeLenses ''RootInfoFiles -- package and global standard library (currently under global-package/.juvix-build) runPackagePathResolver :: forall r a. - (Members '[TaggedLock, Error JuvixError, Files, EvalFileEff] r) => + (Members '[Error JuvixError, TaggedLock, Files, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a @@ -73,12 +73,12 @@ runPackagePathResolver rootPath sem = do Sem r (HashMap (Path Abs Dir) PackageInfo) mkPackageInfos ds fs = do pkgBase <- mkPkgBase - gstdlib <- mkPkgGlobalStdlib + globalPkg <- mkPkgStdlibInGlobal pkgDotJuvix <- mkPackageDotJuvix pkgType <- mkPkgPackageType return . hashMap - $ mkAssoc <$> [pkgBase, pkgType, gstdlib, pkgDotJuvix] + $ mkAssoc <$> [pkgBase, pkgType, globalPkg, pkgDotJuvix] where mkAssoc :: PackageInfo -> (Path Abs Dir, PackageInfo) mkAssoc pkg = (pkg ^. packageRoot, pkg) @@ -86,23 +86,30 @@ runPackagePathResolver rootPath sem = do mkPkgBase :: Sem r PackageInfo mkPkgBase = do let rfiles = fs ^. rootInfoFilesPackageBase + root = ds ^. rootInfoArgPackageBaseDir + pkgTy = PackageBase + pkgId <- mkPackageInfoPackageId root (toList rfiles) pkgTy return PackageInfo - { _packageRoot = ds ^. rootInfoArgPackageBaseDir, + { _packageRoot = root, _packageAvailableRoots = hashSet [ds ^. rootInfoArgPackageBaseDir], _packageJuvixRelativeFiles = rfiles, - _packagePackage = PackageBase + _packagePackage = pkgTy, + _packageInfoPackageId = pkgId } mkPkgPackageType :: Sem r PackageInfo mkPkgPackageType = do let rfiles = fs ^. rootInfoFilesPackage root = ds ^. rootInfoArgPackageDir + pkgTy = PackageType + pkgId <- mkPackageInfoPackageId root (toList rfiles) pkgTy return PackageInfo { _packageRoot = root, _packageJuvixRelativeFiles = rfiles, - _packagePackage = PackageType, + _packagePackage = pkgTy, + _packageInfoPackageId = pkgId, _packageAvailableRoots = hashSet [ ds ^. rootInfoArgPackageDir, @@ -111,26 +118,31 @@ runPackagePathResolver rootPath sem = do ] } - mkPkgGlobalStdlib :: Sem r PackageInfo - mkPkgGlobalStdlib = do + mkPkgStdlibInGlobal :: Sem r PackageInfo + mkPkgStdlibInGlobal = do let root = ds ^. rootInfoArgGlobalStdlibDir jufiles <- findPackageJuvixFiles root let rfiles = hashSet jufiles + pkgTy = PackageStdlibInGlobalPackage + pkgId <- mkPackageInfoPackageId root (toList rfiles) pkgTy return PackageInfo { _packageRoot = root, _packageJuvixRelativeFiles = rfiles, + _packageInfoPackageId = pkgId, _packageAvailableRoots = hashSet [ ds ^. rootInfoArgPackageBaseDir, ds ^. rootInfoArgGlobalStdlibDir ], - _packagePackage = PackageGlobalStdlib + _packagePackage = pkgTy } mkPackageDotJuvix :: Sem r PackageInfo mkPackageDotJuvix = do let rfiles = hashSet [packageFilePath] + pkgTy = PackageDotJuvix + pkgId <- mkPackageInfoPackageId rootPath (toList rfiles) pkgTy return PackageInfo { _packageRoot = rootPath, @@ -142,7 +154,8 @@ runPackagePathResolver rootPath sem = do ds ^. rootInfoArgGlobalStdlibDir, rootPath ], - _packagePackage = PackageDotJuvix + _packagePackage = pkgTy, + _packageInfoPackageId = pkgId } rootInfoDirs :: Sem r RootInfoDirs diff --git a/src/Juvix/Compiler/Pipeline/Repl.hs b/src/Juvix/Compiler/Pipeline/Repl.hs index 545a5577fb..493930e2be 100644 --- a/src/Juvix/Compiler/Pipeline/Repl.hs +++ b/src/Juvix/Compiler/Pipeline/Repl.hs @@ -18,9 +18,7 @@ import Juvix.Compiler.Pipeline.Artifacts import Juvix.Compiler.Pipeline.Artifacts.PathResolver import Juvix.Compiler.Pipeline.Driver import Juvix.Compiler.Pipeline.EntryPoint -import Juvix.Compiler.Pipeline.Loader.PathResolver (runDependencyResolver) -import Juvix.Compiler.Pipeline.Loader.PathResolver.Base -import Juvix.Compiler.Pipeline.Loader.PathResolver.Error +import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree (withImportTree) import Juvix.Compiler.Pipeline.Package.Loader.Error import Juvix.Compiler.Pipeline.Package.Loader.EvalEff.IO diff --git a/src/Juvix/Compiler/Store/Core/Language.hs b/src/Juvix/Compiler/Store/Core/Language.hs index 3313fbf45f..b819588696 100644 --- a/src/Juvix/Compiler/Store/Core/Language.hs +++ b/src/Juvix/Compiler/Store/Core/Language.hs @@ -5,11 +5,10 @@ module Juvix.Compiler.Store.Core.Language where import Juvix.Compiler.Core.Language.Nodes -import Juvix.Extra.Serialize {---------------------------------------------------------------------------------} -data LetRecInfo = LetRecInfo +newtype LetRecInfo = LetRecInfo { _letRecInfoPragmas :: [Pragmas] } deriving stock (Generic) @@ -18,7 +17,7 @@ instance Serialize LetRecInfo instance NFData LetRecInfo -data LambdaInfo = LambdaInfo +newtype LambdaInfo = LambdaInfo { _lambdaInfoPragma :: Pragmas } deriving stock (Generic) diff --git a/src/Juvix/Data.hs b/src/Juvix/Data.hs index 6342d658cc..bfacc8c359 100644 --- a/src/Juvix/Data.hs +++ b/src/Juvix/Data.hs @@ -1,6 +1,7 @@ module Juvix.Data ( module Juvix.Data.Effect, module Juvix.Data.Error, + module Juvix.Data.PackageId, module Juvix.Data.ProjectionKind, module Juvix.Data.NumThreads, module Juvix.Data.Fixity, @@ -41,6 +42,7 @@ import Juvix.Data.Keyword import Juvix.Data.Loc import Juvix.Data.NameId qualified import Juvix.Data.NumThreads +import Juvix.Data.PackageId import Juvix.Data.ParsedItem import Juvix.Data.Polarity import Juvix.Data.Pragmas diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index f61b6680c3..63f8fa7cb3 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/src/Juvix/Data/CodeAnn.hs @@ -5,11 +5,17 @@ module Juvix.Data.CodeAnn ) where +import Data.Versions (prettySemVer) import Juvix.Compiler.Concrete.Data.Name +import Juvix.Data.Error.GenericError +import Juvix.Data.IsImplicit import Juvix.Data.Keyword +import Juvix.Data.NameId import Juvix.Data.NameKind +import Juvix.Data.PackageId +import Juvix.Data.WithLoc import Juvix.Extra.Strings qualified as Str -import Juvix.Prelude +import Juvix.Prelude.Base import Juvix.Prelude.Pretty hiding (braces, brackets, group, list, parens) import Prettyprinter.Render.Terminal (Color (..), bold, colorDull) @@ -44,6 +50,11 @@ instance HasNameKind CodeAnnReference where getNameKind = (^. codeAnnReferenceNameKindPretty) getNameKindPretty = (^. codeAnnReferenceNameKindPretty) +instance PrettyCodeAnn PackageId where + ppCodeAnn pid = + annotate AnnImportant (pretty (pid ^. packageIdName)) + <+> pretty (prettySemVer (pid ^. packageIdVersion)) + instance HasNameKindAnn Ann where annNameKind = AnnKind diff --git a/src/Juvix/Data/Loc.hs b/src/Juvix/Data/Loc.hs index e655f564e9..ad9d527dbf 100644 --- a/src/Juvix/Data/Loc.hs +++ b/src/Juvix/Data/Loc.hs @@ -117,6 +117,9 @@ makeLenses ''FileLoc makeLenses ''Loc makeLenses ''Pos +intervalFromFile :: Path Abs File -> Interval +intervalFromFile = singletonInterval . mkInitialLoc + singletonInterval :: Loc -> Interval singletonInterval l = Interval diff --git a/src/Juvix/Data/ModuleId.hs b/src/Juvix/Data/ModuleId.hs index 29818e43fb..b0e4f13540 100644 --- a/src/Juvix/Data/ModuleId.hs +++ b/src/Juvix/Data/ModuleId.hs @@ -1,5 +1,6 @@ module Juvix.Data.ModuleId where +import Juvix.Data.PackageId import Juvix.Data.TopModulePathKey import Juvix.Extra.Serialize import Juvix.Prelude.Base @@ -7,8 +8,7 @@ import Prettyprinter data ModuleId = ModuleId { _moduleIdPath :: TopModulePathKey, - _moduleIdPackage :: Text, - _moduleIdPackageVersion :: Text + _moduleIdPackageId :: PackageId } deriving stock (Show, Eq, Ord, Generic, Data) @@ -27,6 +27,9 @@ defaultModuleId :: ModuleId defaultModuleId = ModuleId { _moduleIdPath = nonEmptyToTopModulePathKey (pure "$DefaultModule$"), - _moduleIdPackage = "$", - _moduleIdPackageVersion = "1.0" + _moduleIdPackageId = + PackageId + { _packageIdName = "$", + _packageIdVersion = SemVer 1 0 0 Nothing Nothing + } } diff --git a/src/Juvix/Data/NameKind.hs b/src/Juvix/Data/NameKind.hs index f2bd976169..88f05a4b61 100644 --- a/src/Juvix/Data/NameKind.hs +++ b/src/Juvix/Data/NameKind.hs @@ -1,7 +1,7 @@ module Juvix.Data.NameKind where import Juvix.Extra.Serialize -import Juvix.Prelude +import Juvix.Prelude.Base import Juvix.Prelude.Pretty import Prettyprinter.Render.Terminal diff --git a/src/Juvix/Data/PackageId.hs b/src/Juvix/Data/PackageId.hs new file mode 100644 index 0000000000..74d3b9c67a --- /dev/null +++ b/src/Juvix/Data/PackageId.hs @@ -0,0 +1,28 @@ +module Juvix.Data.PackageId where + +import Juvix.Extra.Strings qualified as Str +import Juvix.Prelude.Base + +data PackageId = PackageId + { _packageIdName :: Text, + _packageIdVersion :: SemVer + } + deriving stock (Show, Ord, Eq, Data, Generic) + +makeLenses ''PackageId + +packageBaseId :: PackageId +packageBaseId = + PackageId + { _packageIdName = Str.packageBase, + _packageIdVersion = defaultVersion + } + +defaultVersion :: SemVer +defaultVersion = SemVer 0 0 0 Nothing Nothing + +instance Serialize PackageId + +instance Hashable PackageId + +instance NFData PackageId diff --git a/src/Juvix/Data/SHA256.hs b/src/Juvix/Data/SHA256.hs index 01ac0306f5..e5b21cdc69 100644 --- a/src/Juvix/Data/SHA256.hs +++ b/src/Juvix/Data/SHA256.hs @@ -4,13 +4,58 @@ import Crypto.Hash.SHA256 qualified as SHA256 import Data.ByteString.Base16 qualified as Base16 import Juvix.Prelude -digestText :: Text -> Text -digestText = +hashToText :: ByteString -> Text +hashToText = decodeUtf8Lenient . Base16.encode + +digestText :: Text -> Text +digestText = + hashToText . SHA256.hash . encodeUtf8 --- | Create a HEX encoded, SHA256 digest of the contents of a file. +-- | Create a HEX encoded, SHA256 digest of the contents of a file digestFile :: (Member Files r) => Path Abs File -> Sem r Text -digestFile = fmap (decodeUtf8Lenient . Base16.encode . SHA256.hash) . readFileBS' +digestFile = fmap hashToText . digestFileBS + +digestFileBS :: (Member Files r) => Path Abs File -> Sem r ByteString +digestFileBS = fmap SHA256.hash . readFileBS' + +data SHA256Builder :: Effect where + BuilderDigestFiles :: (Foldable l) => l (Path Abs File) -> SHA256Builder m () + +makeSem ''SHA256Builder + +builderDigestFile :: (Members '[SHA256Builder] r) => Path Abs File -> Sem r () +builderDigestFile p = builderDigestFiles [p] + +runSHA256Builder :: (Members '[Files] r) => Sem (SHA256Builder ': r) a -> Sem r (Text, a) +runSHA256Builder m = fmap + ( first + ( hashToText + . SHA256.finalize + ) + ) + $ reinterpret' m (runState SHA256.init) + $ \case + BuilderDigestFiles f -> do + fs <- mapM readFileBS' (toList f) + modify (`SHA256.updates` fs) + +ignoreSHA256Builder :: Sem (SHA256Builder ': r) a -> Sem r a +ignoreSHA256Builder = interpret $ \case + BuilderDigestFiles {} -> return () + +execSHA256Builder :: (Members '[Files] r) => Sem (SHA256Builder ': r) a -> Sem r Text +execSHA256Builder = fmap fst . runSHA256Builder + +-- | Create a HEX encoded, SHA256 digest of the contents of some files in the +-- given order. Note that the order of the paths is relevant +digestFilesList :: (Members '[Files] r, Foldable l) => l (Path Abs File) -> Sem r Text +digestFilesList = execSHA256Builder . builderDigestFiles + +-- | Create a HEX encoded, SHA256 digest of the contents of the files. Order of +-- paths and repeated elements do not affect the result. +digestFiles :: (Members '[Files] r, Foldable l) => l (Path Abs File) -> Sem r Text +digestFiles = digestFilesList . ordNubSort diff --git a/src/Juvix/Extra/Serialize.hs b/src/Juvix/Extra/Serialize.hs index a5d814aa6b..dd693c9554 100644 --- a/src/Juvix/Extra/Serialize.hs +++ b/src/Juvix/Extra/Serialize.hs @@ -19,13 +19,6 @@ import Juvix.Prelude.Path instance Serialize (Path Abs File) -instance Serialize Text where - put txt = Serial.put (unpack txt) - - get = pack <$> Serial.get - -instance (Serialize a) => Serialize (NonEmpty a) - instance (Hashable k, Serialize k, Serialize a) => Serialize (HashMap k a) where put m = Serial.put (HashMap.toList m) diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index fd6fbe733c..944e06baa3 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/src/Juvix/Prelude/Base.hs @@ -1,8 +1,49 @@ module Juvix.Prelude.Base ( module Juvix.Prelude.Base.Foundation, module Juvix.Prelude.Effects, + module Juvix.Prelude.Base, ) where import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects + +groupSortOnWithM :: forall a b m. (Ord b, Monad m) => (a -> m b) -> [a] -> m [(NonEmpty a, b)] +groupSortOnWithM f l = do + l' <- mapWithM f l + return (run . execAccumList . runInputList (sortOn snd l') $ repeatOnInput go) + where + go :: forall r. (Members '[Input (a, b), Accum (NonEmpty a, b)] r) => (a, b) -> Sem r () + go (e, eb) = do + es <- map fst <$> inputWhile @(a, b) ((== eb) . snd) + accum (e :| es, eb) + +groupSortOnWith :: forall a b. (Ord b) => (a -> b) -> [a] -> [(NonEmpty a, b)] +groupSortOnWith f = runIdentity . groupSortOnWithM (return . f) + +groupSortOnM :: (Ord b, Monad m) => (a -> m b) -> [a] -> m [NonEmpty a] +groupSortOnM f = fmap (map fst) . groupSortOnWithM f + +groupSortOn :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] +groupSortOn f = map fst . groupSortOnWith f + +groupSortOn' :: (Ord b) => (a -> b) -> [a] -> [[a]] +groupSortOn' f = map toList . groupSortOn f + +findRepeatedOnM :: forall a b m. (Ord b, Monad m) => (a -> m b) -> [a] -> m [(NonEmpty a, b)] +findRepeatedOnM f = fmap (mapMaybe rep) . groupSortOnWithM f + where + rep :: (NonEmpty a, b) -> Maybe (NonEmpty a, b) + rep = \case + (n@(_ :| _ : _), b) -> Just (n, b) + _ -> Nothing + +findRepeatedOn :: forall a b. (Ord b) => (a -> b) -> [a] -> [(NonEmpty a, b)] +findRepeatedOn f = runIdentity . findRepeatedOnM (return . f) + +-- | Returns the repeated elements +findRepeated :: forall a. (Ord a) => [a] -> [a] +findRepeated = map (head . fst) . findRepeatedOn id + +allDifferent :: forall a. (Ord a) => [a] -> Bool +allDifferent = null . findRepeated diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 87908e1e2d..9a93688882 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -1,9 +1,11 @@ +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} module Juvix.Prelude.Base.Foundation ( module Juvix.Prelude.Base.Foundation, module Control.Applicative, module Data.Tree, + module Data.Versions, module Data.Graph, module Text.Show.Unicode, module Data.Map.Strict, @@ -66,6 +68,7 @@ module Juvix.Prelude.Base.Foundation module Control.Monad.Catch, module Control.Monad.Zip, module Data.String.Interpolate, + module Data.Serialize, Data, Text, pack, @@ -174,6 +177,8 @@ import Data.Maybe import Data.Monoid import Data.Ord import Data.Semigroup (Semigroup, sconcat, (<>)) +import Data.Serialize (Serialize) +import Data.Serialize as Serial import Data.Set (Set) import Data.Set qualified as Set import Data.Singletons hiding ((@@)) @@ -196,6 +201,8 @@ import Data.Tree hiding (levels) import Data.Tuple.Extra hiding (both) import Data.Type.Equality (type (~)) import Data.Typeable hiding (TyCon) +import Data.Versions (SemVer (..), Versioning (..)) +import Data.Versions qualified as Versions import Data.Void import Data.Word import GHC.Base (assert) @@ -339,18 +346,6 @@ replaceText texts txt = fromMaybe txt (HashMap.lookup txt (HashMap.fromList text -- Foldable -------------------------------------------------------------------------------- --- | Returns the repeated elements -findRepeated :: forall a. (Ord a) => [a] -> [a] -findRepeated = mapMaybe rep . groupSortOn' id - where - rep :: [a] -> Maybe a - rep = \case - a : _ : _ -> Just a - _ -> Nothing - -allDifferent :: forall a. (Ord a) => [a] -> Bool -allDifferent = null . findRepeated - allSame :: forall t a. (Eq a, Foldable t) => t a -> Bool allSame t = case nonEmpty t of Nothing -> True @@ -466,6 +461,11 @@ zip4Exact [] [] [] [] = [] zip4Exact (x1 : t1) (x2 : t2) (x3 : t3) (x4 : t4) = (x1, x2, x3, x4) : zip4Exact t1 t2 t3 t4 zip4Exact _ _ _ _ = error "zip4Exact" +findJustM :: forall a b m. (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +findJustM f = \case + [] -> return Nothing + x : xs -> f x >>= maybe (findJustM f xs) (return . Just) + -- | Returns the first element that returns Just and the list with the remaining elements findJustAndRemove :: forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a]) findJustAndRemove p = go [] @@ -503,12 +503,6 @@ nonEmpty' = fromJust . nonEmpty _nonEmpty :: Lens' [a] (Maybe (NonEmpty a)) _nonEmpty f x = maybe [] toList <$> f (nonEmpty x) -groupSortOn :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] -groupSortOn f = map nonEmpty' . List.groupSortOn f - -groupSortOn' :: (Ord b) => (a -> b) -> [a] -> [[a]] -groupSortOn' = List.groupSortOn - -------------------------------------------------------------------------------- -- Errors -------------------------------------------------------------------------------- @@ -771,6 +765,10 @@ hashMapFromHashSetM s fun = hashMapFromHashSet :: (Hashable k) => HashSet k -> (k -> v) -> HashMap k v hashMapFromHashSet s fun = hashMap [(x, fun x) | x <- toList s] +-- | Sorts and removes duplicates +ordNubSort :: (Foldable f, Ord k) => f k -> [k] +ordNubSort = toList . ordSet + ordMap :: (Foldable f, Ord k) => f (k, v) -> Map k v ordMap = Map.fromList . toList @@ -912,3 +910,16 @@ allFiniteSequences elems = build 0 [] seq <- ofLength (n - 1) e <- elems return (pure e <> seq) + +instance Serialize Text where + put txt = Serial.put (unpack txt) + + get = pack <$> Serial.get + +instance (Serialize a) => Serialize (NonEmpty a) + +instance Serialize Versions.Chunk + +instance Serialize Versions.Release + +instance Serialize SemVer diff --git a/src/Juvix/Prelude/Effects/Base.hs b/src/Juvix/Prelude/Effects/Base.hs index 41dd47cef4..9c32c313e7 100644 --- a/src/Juvix/Prelude/Effects/Base.hs +++ b/src/Juvix/Prelude/Effects/Base.hs @@ -234,6 +234,14 @@ reinterpretH :: Sem r b reinterpretH = E.reinterpret +reinterpret' :: + (DispatchOf e ~ 'Dynamic) => + Sem (e ': r) a -> + (Sem handlerEs a -> Sem r b) -> + EffectHandlerFO e handlerEs -> + Sem r b +reinterpret' m re i = reinterpret re i m + reinterpret :: (DispatchOf e ~ 'Dynamic) => (Sem handlerEs a -> Sem r b) -> diff --git a/src/Juvix/Prelude/Effects/Input.hs b/src/Juvix/Prelude/Effects/Input.hs index d2f1f6fe25..616287d164 100644 --- a/src/Juvix/Prelude/Effects/Input.hs +++ b/src/Juvix/Prelude/Effects/Input.hs @@ -31,7 +31,7 @@ input = Input [] -> (Nothing, Input []) Input (i : is) -> (Just i, Input is) -inputWhile :: (Member (Input i) r) => (i -> Bool) -> Sem r [i] +inputWhile :: forall i r. (Member (Input i) r) => (i -> Bool) -> Sem r [i] inputWhile c = stateStaticRep $ \case diff --git a/src/Parallel/ProgressLog.hs b/src/Parallel/ProgressLog.hs index 18cb1f72d9..45731ee607 100644 --- a/src/Parallel/ProgressLog.hs +++ b/src/Parallel/ProgressLog.hs @@ -104,8 +104,8 @@ runProgressLogOptions opts m = do wait logHandler return x where - getPackageTag :: Path Abs Dir -> Doc CodeAnn - getPackageTag pkgRoot = opts ^. progressLogOptionsPackages . at pkgRoot . _Just . packagePackage . packageLikeNameAndVersion + packageTag :: Path Abs Dir -> Doc CodeAnn + packageTag pkgRoot = packageInfoNameAndVersion (opts ^?! progressLogOptionsPackages . at pkgRoot . _Just) tree :: ImportTree tree = opts ^. progressLogOptionsImportTree @@ -160,12 +160,13 @@ runProgressLogOptions opts m = do handler :: TVar ProgressLogState -> LogQueue -> EffectHandlerFO ProgressLog r handler st logs = \case - ProgressLog i -> + ProgressLog i -> do + let tag = packageTag fromPackage atomically $ do n <- getNextNumber let k | fromMainPackage = LogMainPackage - | otherwise = LogDependency (getPackageTag fromPackage) + | otherwise = LogDependency tag d = LogItemDetails { _logItemDetailsKind = k, diff --git a/tests/negative/AmbiguousPackageId/Main.juvix b/tests/negative/AmbiguousPackageId/Main.juvix new file mode 100644 index 0000000000..fef5380749 --- /dev/null +++ b/tests/negative/AmbiguousPackageId/Main.juvix @@ -0,0 +1 @@ +module Main; diff --git a/tests/negative/AmbiguousPackageId/Package.juvix b/tests/negative/AmbiguousPackageId/Package.juvix new file mode 100644 index 0000000000..ade67217d3 --- /dev/null +++ b/tests/negative/AmbiguousPackageId/Package.juvix @@ -0,0 +1,9 @@ +module Package; + +import PackageDescription.V2 open; + +package : Package := + defaultPackage@?{ + name := "ambiguouspackageid"; + dependencies := [path "dep1"; path "dep2"]; + }; diff --git a/tests/negative/AmbiguousPackageId/dep1/Package.juvix b/tests/negative/AmbiguousPackageId/dep1/Package.juvix new file mode 100644 index 0000000000..8fc198954c --- /dev/null +++ b/tests/negative/AmbiguousPackageId/dep1/Package.juvix @@ -0,0 +1,9 @@ +module Package; + +import PackageDescription.V2 open; + +package : Package := + defaultPackage@?{ + name := "dep"; + dependencies := []; + }; diff --git a/tests/negative/AmbiguousPackageId/dep1/main.juvix b/tests/negative/AmbiguousPackageId/dep1/main.juvix new file mode 100644 index 0000000000..8bffabe306 --- /dev/null +++ b/tests/negative/AmbiguousPackageId/dep1/main.juvix @@ -0,0 +1 @@ +module main; diff --git a/tests/negative/AmbiguousPackageId/dep2/Package.juvix b/tests/negative/AmbiguousPackageId/dep2/Package.juvix new file mode 100644 index 0000000000..8fc198954c --- /dev/null +++ b/tests/negative/AmbiguousPackageId/dep2/Package.juvix @@ -0,0 +1,9 @@ +module Package; + +import PackageDescription.V2 open; + +package : Package := + defaultPackage@?{ + name := "dep"; + dependencies := []; + }; diff --git a/tests/negative/AmbiguousPackageId/dep2/main.juvix b/tests/negative/AmbiguousPackageId/dep2/main.juvix new file mode 100644 index 0000000000..8bffabe306 --- /dev/null +++ b/tests/negative/AmbiguousPackageId/dep2/main.juvix @@ -0,0 +1 @@ +module main;