Commit 25ee18bb authored by Michael Hanus 's avatar Michael Hanus
Browse files

CPM updated: bug fix in semantic version checker, size of repository cache...

CPM updated: bug fix in semantic version checker, size of repository cache reduced to reduce load time
parent def2aa01
......@@ -10,18 +10,17 @@ module CPM.AbstractCurry
, readAbstractCurryFromDeps
, transformAbstractCurryInDeps
, applyModuleRenames
, tcArgsOfType
) where
import Distribution (FrontendTarget (..), FrontendParams (..), defaultParams
import Distribution ( FrontendTarget (..), FrontendParams (..), defaultParams
, callFrontendWithParams, setQuiet, setFullPath
, sysLibPath, inCurrySubdir, modNameToPath
, inCurrySubdirModule, lookupModuleSource)
import List (intercalate, nub)
import FilePath ((</>), (<.>), takeFileName, replaceExtension)
import AbstractCurry.Files (readAbstractCurryFile, writeAbstractCurryFile)
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Select (imports)
, inCurrySubdirModule, lookupModuleSource )
import List ( intercalate, nub )
import FilePath ( (</>), (<.>), takeFileName, replaceExtension )
import AbstractCurry.Files ( readAbstractCurryFile, writeAbstractCurryFile )
import AbstractCurry.Pretty ( showCProg )
import AbstractCurry.Select ( imports )
import AbstractCurry.Transform
import AbstractCurry.Types
import System
......@@ -110,20 +109,3 @@ applyModuleRenames names prog =
Just mod' -> (mod', n)
Nothing -> mn
--- Checks whether a type expression is a type constructor application.
--- If this is the case, return the type constructor and the type arguments.
tcArgsOfType :: CTypeExpr -> Maybe (QName,[CTypeExpr])
tcArgsOfType texp =
maybe Nothing
(\tc -> Just (tc, targsOfApply texp))
(tconOfApply texp)
where
tconOfApply te = case te of CTApply (CTCons qn) _ -> Just qn
CTApply tc _ -> tconOfApply tc
_ -> Nothing
targsOfApply te = case te of
CTApply (CTCons _) ta -> [ta]
CTApply tc ta -> targsOfApply tc ++ [ta]
_ -> [] -- should not occur
......@@ -118,12 +118,7 @@ setCompilerVersion cfg0 = do
, baseVersion = if null initbase
then Dist.baseVersion
else initbase }
else do (c1,sname,e1) <- evalCmd (curryExec cfg) ["--compiler-name"] ""
(c2,svers,e2) <- evalCmd (curryExec cfg) ["--numeric-version"] ""
(c3,sbver,e3) <- evalCmd (curryExec cfg) ["--base-version"] ""
when (c1 > 0 || c2 > 0 || c3 > 0) $
error $ "Cannot determine compiler version:\n" ++
unlines (filter (not . null) [e1,e2,e3])
else do (sname,svers,sbver) <- getCompilerVersion (curryExec cfg)
let cname = strip sname
cvers = strip svers
bvers = strip sbver
......@@ -136,6 +131,23 @@ setCompilerVersion cfg0 = do
then bvers
else initbase }
where
getCompilerVersion currybin = do
debugMessage $ "Getting version information from " ++ currybin
(r,s,e) <- evalCmd currybin
["--compiler-name","--numeric-version","--base-version"] ""
if r>0
then error $ "Cannot determine compiler version:\n" ++ e
else case lines s of
[sname,svers,sbver] -> return (sname,svers,sbver)
_ -> do debugMessage $ "Query version information again..."
(c1,sname,e1) <- evalCmd currybin ["--compiler-name"] ""
(c2,svers,e2) <- evalCmd currybin ["--numeric-version"] ""
(c3,sbver,e3) <- evalCmd currybin ["--base-version"] ""
when (c1 > 0 || c2 > 0 || c3 > 0) $
error $ "Cannot determine compiler version:\n" ++
unlines (filter (not . null) [e1,e2,e3])
return (sname,svers,sbver)
currVersion = (Dist.curryCompiler, Dist.curryCompilerMajorVersion,
Dist.curryCompilerMinorVersion)
......
......@@ -35,6 +35,7 @@ import List ( intercalate, intersect, nub, splitOn, isPrefixOf, isInfixOf
import Maybe ( isJust, fromJust, fromMaybe, listToMaybe )
import System ( getEnviron, setEnviron, unsetEnviron )
import AbstractCurry.Select ( tconsArgsOfType )
import Analysis.Types ( Analysis )
import Analysis.ProgInfo ( ProgInfo, emptyProgInfo, combineProgInfo
, lookupProgInfo)
......@@ -43,8 +44,7 @@ import Analysis.TypeUsage ( typesInValuesAnalysis )
import CASS.Server ( analyzeGeneric )
import Text.Pretty ( pPrint, text, indent, vcat, (<+>), (<$$>) )
import CPM.AbstractCurry ( readAbstractCurryFromDeps, loadPathForPackage
, tcArgsOfType )
import CPM.AbstractCurry ( readAbstractCurryFromDeps, loadPathForPackage )
import CPM.Config ( Config (curryExec) )
import CPM.Diff.API as APIDiff
import CPM.Diff.CurryComments (readComments, getFuncComment)
......@@ -334,7 +334,7 @@ genLimitFunction typeinfos tdecl = case tdecl of
error "type2LimOp: cannot generate limit operation for function type"
_ -> maybe (error "type2LimOp: cannot generate limit operation for type application")
(\ (tc,ts) -> applyF (transCTCon2Limit tc) (map type2LimOp ts))
(tcArgsOfType texp)
(tconsArgsOfType texp)
--- Generates a test function to compare two versions of the given function.
......@@ -394,7 +394,7 @@ genTestFunction info tm (isprod,f) =
(\_ -> case findTrans tm texp of
Just n -> applyF ("Compare", n) [CVar v]
Nothing -> CVar v)
(tcArgsOfType texp)
(tconsArgsOfType texp)
_ -> error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
-- encode a Curry identifier into an alphanum form:
......@@ -526,7 +526,7 @@ genTranslatorFunction cfg repo gc info acy tm texp =
"Cannot generate translator function for type:\n" ++
pPrint (ppCTypeExpr defaultOptions texp))
fst
(tcArgsOfType texp)
(tconsArgsOfType texp)
in
-- Don't generate another translator if there already is one for the current
-- type.
......@@ -648,7 +648,7 @@ instantiate tdecl texp = case texp of
CFuncType _ _ -> error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType"
_ -> maybe (error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTApply")
(\ (_,texps) -> instantiate' tdecl texps)
(tcArgsOfType texp)
(tconsArgsOfType texp)
where
instantiate' (CType n v vs cs d) es = CType n v vs (map cons cs) d
where
......@@ -705,7 +705,7 @@ type2LimitFunc texp = case texp of
(error
"type2LimitFunc: cannot generate limit operation for type application")
(\ (tc,ts) -> applyF (transCTCon2Limit tc) (map type2LimitFunc ts))
(tcArgsOfType texp)
(tconsArgsOfType texp)
-- Translate a type constructor name to the name of the corresponding limit
-- operation:
......@@ -1065,9 +1065,9 @@ filterNonMatchingTypes dirA dirB deps acyCache allFuncs =
typesEqual :: CTypeExpr -> String -> String -> [Package] -> ACYCache
-> [CTypeExpr] -> IO (ErrorLogger (ACYCache, Bool))
typesEqual texp dirA dirB deps acyCache checked =
maybe (failIO "typesEqual not called on type constructor")
maybe (failIO $ "typesEqual not called on type constructor: " ++ show texp)
(succeedIO . fst)
(tcArgsOfType texp) |>= \n -> let (mod,_) = n in
(tconsArgsOfType texp) |>= \n -> let (mod,_) = n in
if texp `elem` checked
then succeedIO (acyCache, True)
else readCached dirA deps acyCache mod |>= \(acy',modA) ->
......
......@@ -37,7 +37,7 @@ import CPM.Package
import CPM.Resolution ( isCompatibleToCompiler, showResult )
import CPM.Repository ( Repository, readRepository, findVersion, listPackages
, findAllVersions, findLatestVersion, updateRepository
, useUpdateHelp, searchPackages, updateRepositoryCache
, useUpdateHelp, searchPackages, cleanRepositoryCache
, readPackageFromRepository
, getAllPackageVersions, getPackageVersion )
import CPM.PackageCache.Runtime ( dependencyPathsSeparate, writePackageConfig )
......@@ -51,7 +51,7 @@ cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText =
"Curry Package Manager <curry-language.org/tools/cpm> (version of 20/12/2017)"
"Curry Package Manager <curry-language.org/tools/cpm> (version of 21/12/2017)"
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
......@@ -96,21 +96,26 @@ runWithArgs opts = do
Add o -> addCmd o config
Clean -> cleanPackage Info
New o -> newPackage o
_ -> do repo <- readRepository config
case optCommand opts of
List o -> listCmd o config repo
Search o -> searchCmd o config repo
Checkout o -> checkoutCmd o config repo
Install o -> installCmd o config repo
Upgrade o -> upgradeCmd o config repo
Diff o -> diffCmd o config repo
_ -> error "Internal command processing error!"
cmd -> do repo <- readRepository config (cmdWithLargeRepoCache cmd)
case optCommand opts of
List o -> listCmd o config repo
Search o -> searchCmd o config repo
Checkout o -> checkoutCmd o config repo
Install o -> installCmd o config repo
Upgrade o -> upgradeCmd o config repo
Diff o -> diffCmd o config repo
_ -> error "Internal command processing error!"
mapIO showLogEntry msgs
let allOk = all (levelGte Info) (map logLevelOf msgs) &&
either (\le -> levelGte Info (logLevelOf le))
(const True)
result
exitWith (if allOk then 0 else 1)
where
cmdWithLargeRepoCache cmd =
case cmd of List _ -> True
Search _ -> True
_ -> False
data Options = Options
{ optLogLevel :: LogLevel
......@@ -698,7 +703,7 @@ checkExecutables executables = do
configCmd :: ConfigOptions -> Config -> IO (ErrorLogger ())
configCmd opts cfg = do
if configAll opts
then readRepository cfg >>= \repo ->
then readRepository cfg False >>= \repo ->
readGlobalCache cfg repo |>= \gc ->
putStrLn configS >>
putStrLn "Installed packages:\n" >>
......@@ -1058,7 +1063,7 @@ addPackageCmd pkgdir force config = do
createDirectoryIfMissing True pkgRepositoryDir
copyFile (pkgdir </> "package.json") (pkgRepositoryDir </> "package.json")
copyDirectory pkgdir pkgInstallDir
updateRepositoryCache config
cleanRepositoryCache config
useForce :: String
useForce = "Use option '-f' or '--force' to overwrite it."
......
......@@ -46,9 +46,9 @@ cacheDirectory :: String -> Package -> String
cacheDirectory dir pkg = dir </> ".cpm" </> "packages" </> packageId pkg
--- Copies a set of packages from the local package cache to the runtime
--- package cache.
copyPackages :: Config -> [Package] -> String -> IO ()
copyPackages cfg pkgs dir = mapIO copyPackage pkgs >> return ()
--- package cache and returns the package specifications.
copyPackages :: Config -> [Package] -> String -> IO (ErrorLogger [Package])
copyPackages cfg pkgs dir = mapEL copyPackage pkgs
where
copyPackage pkg = do
cdir <- ensureCacheDirectory dir
......@@ -59,7 +59,7 @@ copyPackages cfg pkgs dir = mapIO copyPackage pkgs >> return ()
then -- in order to obtain complete package specification:
readPackageFromRepository cfg pkg |>= \reppkg ->
copyDirectoryFollowingSymlinks pkgDir cdir >>
writePackageConfig cfg destDir reppkg |> succeedIO ()
writePackageConfig cfg destDir reppkg >> succeedIO reppkg
else error $ "Package " ++ packageId pkg ++
" could not be found in package cache."
where
......
......@@ -113,12 +113,13 @@ elemBy f (x:xs) = if f x
else elemBy f xs
--- Links the dependencies of a package to its local cache and copies them to
--- its runtime cache.
--- its runtime cache. Returns the package specifications of the dependencies.
copyDependencies :: Config -> Package -> [Package] -> String
-> IO (ErrorLogger ())
-> IO (ErrorLogger [Package])
copyDependencies cfg pkg pkgs dir =
LocalCache.linkPackages cfg dir pkgs |>
RuntimeCache.copyPackages cfg pkgs' dir >> succeedIO ()
RuntimeCache.copyPackages cfg pkgs' dir |>= \pkgspecs ->
succeedIO (if pkg `elem` pkgs then pkg : pkgspecs else pkgspecs)
where
pkgs' = filter (/= pkg) pkgs
......@@ -128,7 +129,7 @@ upgradeAllPackages cfg repo dir =
loadPackageSpec dir |>= \pkgSpec ->
LocalCache.clearCache dir >> succeedIO () |>
installLocalDependencies cfg repo dir |>= \ (_,deps) ->
copyDependencies cfg pkgSpec deps dir
copyDependencies cfg pkgSpec deps dir |> succeedIO ()
--- Upgrades a single package and its transitive dependencies.
upgradeSinglePackage :: Config -> Repository -> String -> String
......@@ -142,7 +143,7 @@ upgradeSinglePackage cfg repo dir pkgName =
(LS.setLocallyIgnored originalLS transitiveDeps) |>=
\result -> GC.installMissingDependencies cfg gc (resolvedPackages result) |>
log Info (showDependencies result) |>
copyDependencies cfg pkgSpec (resolvedPackages result) dir
copyDependencies cfg pkgSpec (resolvedPackages result) dir |> succeedIO ()
--- Installs the dependencies of a package.
installLocalDependencies :: Config -> Repository -> String
......@@ -153,8 +154,8 @@ installLocalDependencies cfg repo dir =
resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir |>= \result ->
GC.installMissingDependencies cfg gc (resolvedPackages result) |>
log Info (showDependencies result) |>
copyDependencies cfg pkgSpec (resolvedPackages result) dir |>
succeedIO (pkgSpec, resolvedPackages result)
copyDependencies cfg pkgSpec (resolvedPackages result) dir |>= \cpkgs ->
succeedIO (pkgSpec, cpkgs)
--- Links a directory into the local package cache. Used for `cypm link`.
linkToLocalCache :: String -> String -> IO (ErrorLogger ())
......@@ -202,7 +203,7 @@ resolveAndCopyDependencies cfg repo gc dir =
resolveAndCopyDependenciesForPackage ::
Config -> String -> Package -> IO (ErrorLogger [Package])
resolveAndCopyDependenciesForPackage cfg dir pkgSpec =
readRepository cfg >>= \repo ->
readRepository cfg False >>= \repo ->
GC.readGlobalCache cfg repo |>= \gc ->
resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec
......@@ -217,14 +218,13 @@ resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec =
++ (intercalate "," $ map packageId missingDeps)
++ "\nUse `cypm install` to install missing dependencies."
in if null missingDeps
then copyDependencies cfg pkgSpec deps dir |>= \_ ->
succeedIO deps
then copyDependencies cfg pkgSpec deps dir
else failIO failMsg
--- Resolves the dependencies for a package copy.
resolveDependencies :: Config -> String -> IO (ErrorLogger ResolutionResult)
resolveDependencies cfg dir =
readRepository cfg >>= \repo ->
readRepository cfg False >>= \repo ->
GC.readGlobalCache cfg repo |>= \gc ->
loadPackageSpec dir |->
log Info ("Read package spec from " ++ dir) |>= \pkgSpec ->
......
......@@ -15,7 +15,7 @@ module CPM.Repository
, findAllVersions, findVersion, findLatestVersion
, searchPackages
, listPackages
, useUpdateHelp, updateRepository, updateRepositoryCache
, useUpdateHelp, updateRepository, cleanRepositoryCache
, readPackageFromRepository, getAllPackageVersions, getPackageVersion
) where
......@@ -26,7 +26,7 @@ import FilePath
import IO
import IOExts ( readCompleteFile )
import List
import ReadShowTerm ( showQTerm, readQTerm )
import ReadShowTerm ( showQTerm, readQTerm, showTerm, readUnqualifiedTerm )
import System ( exitWith, system )
import Time
......@@ -128,17 +128,20 @@ allPackages (Repository ps) = ps
--- Uses the cache if it is present or update the cache after reading.
--- If some errors occur, show them and terminate with error exit status.
---
--- @param cfg the configuration to use
readRepository :: Config -> IO Repository
readRepository cfg = do
--- @param cfg - the configuration to use
--- @param large - if true reads the larger cache with more package information
--- (e.g., for searching all packages)
readRepository :: Config -> Bool -> IO Repository
readRepository cfg large = do
warnOldRepo cfg
mbrepo <- readRepositoryCache cfg
mbrepo <- readRepositoryCache cfg large
case mbrepo of
Nothing -> do
infoMessage "Writing repository cache..."
infoMessage $ "Writing " ++ (if large then "large " else "") ++
"repository cache..."
(repo, repoErrors) <- readRepositoryFrom (repositoryDir cfg)
if null repoErrors
then writeRepositoryCache cfg repo >> return repo
then writeRepositoryCache cfg large repo >> return repo
else do putStrLn "Problems while reading the package index:"
mapIO putStrLn repoErrors
exitWith 1
......@@ -208,14 +211,14 @@ updateRepository cfg = do
c <- inDirectory (repositoryDir cfg) $ execQuietCmd $ cleanPullCmd
if c == 0
then do setLastUpdate cfg
updateRepositoryCache cfg
cleanRepositoryCache cfg
log Info "Successfully updated repository"
else failIO $ "Failed to update git repository, return code " ++ show c
else do
c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
if c == 0
then do setLastUpdate cfg
updateRepositoryCache cfg
cleanRepositoryCache cfg
log Info "Successfully updated repository"
else failIO $ "Failed to update git repository, return code " ++ show c
where
......@@ -230,83 +233,103 @@ updateRepository cfg = do
-- which is not relevant for the repository data structure.
--
-- The relevant package fields are:
-- name version synopsis category dependencies
-- compilerCompatibility sourceDirs exportedModules
-- * small cache: name version dependencies compilerCompatibility
-- * large cache: synopsis category sourceDirs exportedModules executableSpec
--- The local file name containing the repository cache as a Curry term.
repositoryCacheFileName :: String
repositoryCacheFileName = "REPOSITORY_CACHE"
--- The file containing the repository cache as a Curry term.
repositoryCache :: Config -> String
repositoryCache cfg = repositoryDir cfg </> repositoryCacheFileName
repositoryCache :: Config -> Bool -> String
repositoryCache cfg large =
repositoryDir cfg </> repositoryCacheFileName ++
(if large then "_LARGE" else "")
--- Updates the repository cache with the current repository index.
updateRepositoryCache :: Config -> IO ()
updateRepositoryCache cfg = do
cleanRepositoryCache cfg
repo <- readRepository cfg
writeRepositoryCache cfg repo
--- The first line of the repository cache (to check version compatibility):
repoCacheVersion :: String
repoCacheVersion = packageVersion ++ "-1"
--- Stores the given repository in the cache.
writeRepositoryCache :: Config -> Repository -> IO ()
writeRepositoryCache cfg repo =
writeFile (repositoryCache cfg)
(packageVersion ++ "\n" ++
showQTerm (map package2tuple (allPackages repo)))
---
--- @param cfg - the configuration to use
--- @param large - if true writes the larger cache with more package information
--- (e.g., for searching all packages)
--- @param repo - the repository to write
writeRepositoryCache :: Config -> Bool -> Repository -> IO ()
writeRepositoryCache cfg large repo =
writeFile (repositoryCache cfg large) $ unlines $
repoCacheVersion :
map (if large then showTerm . package2largetuple
else showTerm . package2smalltuple)
(allPackages repo)
where
package2tuple p =
( name p
, version p
, synopsis p
, category p
, dependencies p
, compilerCompatibility p
, sourceDirs p
, exportedModules p
)
package2smalltuple p =
( name p, version p, dependencies p, compilerCompatibility p )
package2largetuple p =
(package2smalltuple p,
(synopsis p, category p, sourceDirs p, exportedModules p,
executableSpec p))
--- Reads the given repository from the cache.
readRepositoryCache :: Config -> IO (Maybe Repository)
readRepositoryCache cfg = do
let cf = repositoryCache cfg
---
--- @param cfg - the configuration to use
--- @param large - if true reads the larger cache with more package information
--- (e.g., for searching all packages)
readRepositoryCache :: Config -> Bool -> IO (Maybe Repository)
readRepositoryCache cfg large = do
let cf = repositoryCache cfg large
excache <- doesFileExist cf
if excache
then debugMessage ("Reading repository cache from '" ++ cf ++ "'...") >>
catch (readTermInCacheFile cf >>= \repo ->
catch ((if large
then readTermInCacheFile cfg (largetuple2package . uread) cf
else readTermInCacheFile cfg (smalltuple2package . uread) cf)
>>= \repo ->
debugMessage "Finished reading repository cache" >> return repo)
(\_ -> do infoMessage "Cleaning broken repository cache..."
cleanRepositoryCache cfg
return Nothing )
else return Nothing
where
readTermInCacheFile cf = do
h <- openFile cf ReadMode
pv <- hGetLine h
if pv == packageVersion
then hGetContents h >>= \t ->
return $!! Just (Repository (map tuple2package (readQTerm t)))
else do infoMessage "Cleaning repository cache (wrong version)..."
cleanRepositoryCache cfg
return Nothing
tuple2package (nm,vs,sy,cat,dep,cmp,srcs,exps) =
uread s = readUnqualifiedTerm ["CPM.Package","Prelude"] s
smalltuple2package (nm,vs,dep,cmp) =
emptyPackage { name = nm
, version = vs
, synopsis = sy
, category = cat
, dependencies = dep
, compilerCompatibility = cmp
, sourceDirs = srcs
, exportedModules = exps
}
largetuple2package (basics,(sy,cat,srcs,exps,exec)) =
(smalltuple2package basics)
{ synopsis = sy
, category = cat
, sourceDirs = srcs
, exportedModules = exps
, executableSpec = exec
}
readTermInCacheFile :: Config -> (String -> Package) -> String
-> IO (Maybe Repository)
readTermInCacheFile cfg trans cf = do
h <- openFile cf ReadMode
pv <- hGetLine h
if pv == repoCacheVersion
then hGetContents h >>= \t ->
return $!! Just (Repository (map trans (lines t)))
else do infoMessage "Cleaning repository cache (wrong version)..."
cleanRepositoryCache cfg
return Nothing
--- Cleans the repository cache.
cleanRepositoryCache :: Config -> IO ()
cleanRepositoryCache cfg = do
let cachefile = repositoryCache cfg
whenFileExists cachefile $ removeFile cachefile
let smallcachefile = repositoryCache cfg False
largecachefile = repositoryCache cfg True
whenFileExists smallcachefile $ removeFile smallcachefile
whenFileExists largecachefile $ removeFile largecachefile
------------------------------------------------------------------------------
--- Reads a given package from the default repository directory.
......@@ -328,8 +351,9 @@ readPackageFromRepository cfg pkg =
--- @param pkgname - the package name to be retrieved
--- @param pre - should pre-release versions be included?
getAllPackageVersions :: Config -> String -> Bool -> IO [Package]
getAllPackageVersions cfg pkgname pre =
readRepository cfg >>= \repo -> return (findAllVersions repo pkgname pre)
getAllPackageVersions cfg pkgname pre = do
repo <- readRepository cfg False
return (findAllVersions repo pkgname pre)
--- Retrieves a package with a given name and version from the repository.
---
......@@ -337,7 +361,8 @@ getAllPackageVersions cfg pkgname pre =
--- @param pkgname - the package name to be retrieved
--- @param ver - the requested version of the package
getPackageVersion :: Config -> String -> Version -> IO (Maybe Package)
getPackageVersion cfg pkgname ver =
readRepository cfg >>= \repo -> return (findVersion repo pkgname ver)
getPackageVersion cfg pkgname ver = do
repo <- readRepository cfg False
return (findVersion repo pkgname ver)
------------------------------------------------------------------------------
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment