Commit b47fb834 authored by Michael Hanus 's avatar Michael Hanus

CPM updated

parent 05d3f0d0
......@@ -633,7 +633,12 @@ CPM can be configured via the \code{\$HOME/.cpmrc} configuration file. The
following list shows all configuration options and their default values.
\begin{description}
\item[\fbox{\code{REPOSITORY_PATH}}] The path to the index repository.
\item[\fbox{\code{PACKAGE_INDEX_URL}}]
The URL of the central package index
which is used by the \code{update} command to download the
index of all repositories.
\item[\fbox{\code{REPOSITORY_PATH}}] The path to the index of all packages.
Default value: \code{\$HOME/.cpm/index}.
\item[\fbox{\code{PACKAGE_INSTALL_PATH}}] The path to the global package cache.
......@@ -700,8 +705,11 @@ one can execute the command
\section{Some CPM Internals}
\label{sec:internals}
CPM's central package index is a Git repository containing package
specification files. A copy of this Git repository is stored on your
CPM's central package index is contains all package specification files.
It is stored at a central server where the actual location is defined
by CPM's configuration variable \code{PACKAGE_INDEX_URL},
see Section~\ref{sec:config}.
A copy of this index is stored on your
local system in the \code{\$HOME/.cpm/index} directory, unless you
changed the location using the \code{REPOSITORY_PATH} setting. CPM
uses the package index when searching for and installing packages and
......@@ -818,6 +826,8 @@ This command also cleans the global package cache in order to support
the download of fresh package versions.
Note that this also removes local copies of packages
installed by the command \ccode{add --package}.
The option \code{--url} allows to specify a different URL
for the central package index (might be useful for experimental purposes).
\item[\fbox{\code{install}}]
Installs all dependencies of the current package.
......
......@@ -6,7 +6,7 @@
module CPM.Config
( Config ( Config, packageInstallDir, binInstallDir, repositoryDir
, appPackageDir, packageIndexRepository, homePackageDir, curryExec
, appPackageDir, packageIndexURL, homePackageDir, curryExec
, compilerVersion, compilerBaseVersion, baseVersion )
, readConfigurationWith, defaultConfig
, showConfiguration, showCompilerVersion ) where
......@@ -27,12 +27,12 @@ import CPM.ErrorLogger
import CPM.FileUtil ( ifFileExists, getFileInPath )
import CPM.Helpers ( strip )
--- The location of the central package index.
packageIndexURI :: String
packageIndexURI =
--- The default location of the central package index.
packageIndexDefaultURL :: String
packageIndexDefaultURL =
"https://git.ps.informatik.uni-kiel.de/curry-packages/cpm-index.git"
-- if you have an ssh access to git.ps.informatik.uni-kiel.de:
-- "ssh://git@git.ps.informatik.uni-kiel.de:55055/curry-packages/cpm-index.git"
-- If you have an ssh access to git.ps.informatik.uni-kiel.de:
-- "ssh://git@git.ps.informatik.uni-kiel.de:55055/curry-packages/cpm-index.git"
--- Data type containing the main configuration of CPM.
data Config = Config {
......@@ -42,10 +42,10 @@ data Config = Config {
, binInstallDir :: String
--- Directory where the package repository is stored
, repositoryDir :: String
--- Directory where the application packages are stored (cmd 'installapp')
--- Directory where the application packages are stored (cmd 'install')
, appPackageDir :: String
--- URL to the package index repository
, packageIndexRepository :: String
, packageIndexURL :: String
--- The directory where the default home package is stored
, homePackageDir :: String
--- The executable of the Curry system used to compile and check packages
......@@ -71,7 +71,7 @@ defaultConfig = Config
, binInstallDir = "$HOME/.cpm/bin"
, repositoryDir = "$HOME/.cpm/index"
, appPackageDir = "$HOME/.cpm/app_packages"
, packageIndexRepository = packageIndexURI
, packageIndexURL = packageIndexDefaultURL
, homePackageDir = ""
, curryExec = Dist.installDir </> "bin" </> Dist.curryCompiler
, compilerVersion = ( Dist.curryCompiler
......@@ -93,6 +93,7 @@ showConfiguration cfg = unlines
, "BIN_INSTALL_PATH : " ++ binInstallDir cfg
, "APP_PACKAGE_PATH : " ++ appPackageDir cfg
, "HOME_PACKAGE_PATH : " ++ homePackageDir cfg
, "PACKAGE_INDEX_URL : " ++ packageIndexURL cfg
]
--- Shows the compiler version in the configuration.
......@@ -244,13 +245,14 @@ stripProps = map ((map toUpper . filter (/='_') . strip) *** strip)
--- record with a value for that option.
keySetters :: [(String, String -> Config -> Config)]
keySetters =
[ ("REPOSITORYPATH" , \v c -> c { repositoryDir = v })
, ("PACKAGEINSTALLPATH" , \v c -> c { packageInstallDir = v })
[ ("APPPACKAGEPATH" , \v c -> c { appPackageDir = v })
, ("BASEVERSION" , \v c -> c { baseVersion = v })
, ("BININSTALLPATH" , \v c -> c { binInstallDir = v })
, ("APPPACKAGEPATH" , \v c -> c { appPackageDir = v })
, ("HOMEPACKAGEPATH" , \v c -> c { homePackageDir = v })
, ("CURRYBIN" , \v c -> c { curryExec = v })
, ("BASEVERSION" , \v c -> c { baseVersion = v })
, ("HOMEPACKAGEPATH" , \v c -> c { homePackageDir = v })
, ("PACKAGEINDEXURL" , \v c -> c { packageIndexURL = v })
, ("PACKAGEINSTALLPATH" , \v c -> c { packageInstallDir = v })
, ("REPOSITORYPATH" , \v c -> c { repositoryDir = v })
]
--- Sequentially applies a list of functions that transform a value to a value
......
......@@ -56,7 +56,7 @@ cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText =
"Curry Package Manager <curry-language.org/tools/cpm> (version of 13/05/2018)"
"Curry Package Manager <curry-language.org/tools/cpm> (version of 19/06/2018)"
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
......@@ -89,7 +89,7 @@ runWithArgs opts = do
(msgs, result) <- case optCommand opts of
NoCommand -> failIO "NoCommand"
Config o -> configCmd o config
Update -> updateCmd config
Update o -> updateCmd o config
Compiler o -> compiler o config
Exec o -> execCmd o config
Doc o -> docCmd o config
......@@ -129,7 +129,7 @@ data Command
| Uninstall UninstallOptions
| PkgInfo InfoOptions
| Compiler ExecOptions
| Update
| Update UpdateOptions
| List ListOptions
| Search SearchOptions
| Upgrade UpgradeOptions
......@@ -201,6 +201,10 @@ data AddOptions = AddOptions
data NewOptions = NewOptions
{ projectName :: String }
data UpdateOptions = UpdateOptions
{ indexURLs :: [String] -- the URLs of additional index repositories
}
data ExecOptions = ExecOptions
{ exeCommand :: String -- the command to be executed
}
......@@ -286,6 +290,11 @@ newOpts s = case optCommand s of
New opts -> opts
_ -> NewOptions ""
updateOpts :: Options -> UpdateOptions
updateOpts s = case optCommand s of
Update opts -> opts
_ -> UpdateOptions []
execOpts :: Options -> ExecOptions
execOpts s = case optCommand s of
Exec opts -> opts
......@@ -383,8 +392,10 @@ optionParser allargs = optParser
<|> command "clean" (help "Clean the current package")
(\a -> Right $ a { optCommand = Clean }) []
<|> command "new" (help "Create a new package") Right newArgs
<|> command "update" (help "Update the package index")
(\a -> Right $ a { optCommand = Update }) []
<|> command "update"
(help "Update the package index")
(\a -> Right $ a { optCommand = Update (updateOpts a) })
updateArgs
<|> command "curry"
(help "Load package spec and start Curry with correct dependencies.")
(\a -> Right $ a { optCommand = Compiler (execOpts a) })
......@@ -510,6 +521,15 @@ optionParser allargs = optParser
where
remargs = tail (snd (break (=="curry") allargs))
updateArgs =
option (\s a -> let opts = updateOpts a
in Right $ a { optCommand = Update opts
{ indexURLs = s : indexURLs opts } })
( short "u"
<> long "url"
<> metavar "URL"
<> help "URL of the central package index" )
execArgs =
rest (\_ a -> Right $ a { optCommand = Exec (execOpts a)
{ exeCommand = unwords remargs } })
......@@ -736,8 +756,13 @@ configCmd opts cfg = do
------------------------------------------------------------------------------
-- `update` command:
updateCmd :: Config -> IO (ErrorLogger ())
updateCmd cfg = checkRequiredExecutables >> updateRepository cfg
updateCmd :: UpdateOptions -> Config -> IO (ErrorLogger ())
updateCmd opts cfg = do
let cfg' = if null (indexURLs opts)
then cfg
else cfg { packageIndexURL = head (indexURLs opts) }
-- TODO: allow merging from several package indices
checkRequiredExecutables >> updateRepository cfg'
------------------------------------------------------------------------------
-- `deps` command:
......
......@@ -29,8 +29,7 @@ import ReadShowTerm ( showQTerm, readQTerm, showTerm, readUnqualifiedTerm )
import System ( exitWith, system )
import Time
import CPM.Config ( Config, repositoryDir, packageIndexRepository
, packageInstallDir )
import CPM.Config ( Config, repositoryDir )
import CPM.ConfigPackage ( packageVersion )
import CPM.ErrorLogger
import CPM.Package
......
......@@ -11,14 +11,16 @@ module CPM.Repository.Update
import Directory
import FilePath
import List ( isSuffixOf )
import System ( system )
import CPM.Config ( Config, packageInstallDir, packageIndexRepository
import CPM.Config ( Config, packageInstallDir, packageIndexURL
, repositoryDir )
import CPM.ErrorLogger
import CPM.Package
import CPM.Package.Helpers ( cleanPackage )
import CPM.FileUtil ( copyDirectory, inDirectory, removeDirectoryComplete )
import CPM.Package.Helpers ( cleanPackage )
import CPM.FileUtil ( copyDirectory, inDirectory, quote
, recreateDirectory, removeDirectoryComplete )
import CPM.Repository
import CPM.Repository.CacheDB ( tryWriteRepositoryDB )
import CPM.Repository.Select ( addPackageToRepositoryCache
......@@ -34,23 +36,32 @@ updateRepository cfg = do
debugMessage $ "Deleting global package cache: '" ++
packageInstallDir cfg ++ "'"
removeDirectoryComplete (packageInstallDir cfg)
gitExists <- doesDirectoryExist $ (repositoryDir cfg) </> ".git"
if gitExists
then do
c <- inDirectory (repositoryDir cfg) $ execQuietCmd $ cleanPullCmd
if c == 0
then finishUpdate
else failIO $ "Failed to update git repository, return code " ++ show c
else do
c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
if c == 0
then finishUpdate
else failIO $ "Failed to update git repository, return code " ++ show c
debugMessage $ "Recreating package index: '" ++ repositoryDir cfg ++ "'"
recreateDirectory (repositoryDir cfg)
c <- inDirectory (repositoryDir cfg) downloadCommand
if c == 0
then finishUpdate
else failIO $ "Failed to update package index, return code " ++ show c
where
cleanPullCmd q = "git clean -d -f && git reset " ++ q ++ " --hard && " ++
"git pull " ++ q ++ " origin master"
cloneCommand q = unwords ["git clone", q, packageIndexRepository cfg, "."]
downloadCommand
| ".git" `isSuffixOf` piurl
= execQuietCmd $ \q -> unwords ["git clone", q, quote piurl, "."]
| ".tar" `isSuffixOf` piurl
= do let tarfile = "XXX.tar"
c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl]
c2 <- showExecCmd $ unwords ["tar", "-xf", tarfile]
removeFile tarfile
return (c1+c2)
| ".tar.gz" `isSuffixOf` piurl
= do let tarfile = "XXX.tar.gz"
c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl]
c2 <- showExecCmd $ unwords ["tar", "-xzf", tarfile]
removeFile tarfile
return (c1+c2)
| otherwise
= do errorMessage $ "Unknown kind of package index URL: " ++ piurl
return 1
where piurl = packageIndexURL cfg
finishUpdate = do
setLastUpdate cfg
......
......@@ -67,7 +67,7 @@ getInterfaceInfos anaName (mod:mods) =
loadDefaultAnalysisValues :: String -> String -> IO [(QName,a)]
loadDefaultAnalysisValues anaName moduleName = do
(_,fileName) <- findModuleSourceInLoadPath moduleName
let defaultFileName = stripCurrySuffix fileName ++ ".defaults."++anaName
let defaultFileName = stripCurrySuffix fileName ++ ".defaults." ++ anaName
fileExists <- doesFileExist defaultFileName
if fileExists
then do debugMessage 3 ("Load default values from " ++ defaultFileName)
......
......@@ -10,7 +10,7 @@
--- (instead of the data constructors).
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version March 2017
--- @version June 2018
-------------------------------------------------------------------------
module Analysis.Types
......@@ -20,12 +20,13 @@ module Analysis.Types
, combinedSimpleFuncAnalysis, combined2SimpleFuncAnalysis
, combinedSimpleTypeAnalysis
, combinedDependencyFuncAnalysis, combinedDependencyTypeAnalysis
, simpleModuleAnalysis, dependencyModuleAnalysis
, isSimpleAnalysis, isCombinedAnalysis, isFunctionAnalysis
, analysisName, baseAnalysisNames, startValue
, AOutFormat(..)
) where
import FlatCurry.Types ( ConsDecl, FuncDecl, TypeDecl, QName )
import FlatCurry.Types ( Prog, ConsDecl, FuncDecl, TypeDecl, QName )
import FlatCurry.Goodies ( progImports )
import Analysis.ProgInfo ( ProgInfo, combineProgInfo, lookupProgInfo )
......@@ -49,6 +50,8 @@ data Analysis a =
(String -> IO (FuncDecl -> [(QName,a)] -> a))
| CombinedDependencyTypeAnalysis [String] String Bool a
(String -> IO (TypeDecl -> [(QName,a)] -> a))
| SimpleModuleAnalysis String (Prog -> a)
| DependencyModuleAnalysis String (Prog -> [(String,a)] -> a)
--- A simple analysis for functions takes an operation that computes
......@@ -160,18 +163,38 @@ combinedDependencyTypeAnalysis ananame baseAnalysis startval anaType =
[analysisName baseAnalysis] ananame True startval
(runWithBaseAnalysis baseAnalysis anaType)
--- Construct a simple analysis for entire modules.
--- The analysis has a name and takes an operation that computes
--- some information from a given module.
simpleModuleAnalysis :: String -> (Prog -> a) -> Analysis a
simpleModuleAnalysis anaName anaFunc =
SimpleModuleAnalysis anaName anaFunc
--- Construct a module analysis which uses analysis information on
--- imported modules.
--- The analysis has a name and an operation to analyze a module.
--- The analysis operation could use already computed information
--- of imported modules, represented as a list of module name/information pairs.
--- Note that a fixpoint iteration is not necessary
--- since module dependencies must be acyclic.
dependencyModuleAnalysis :: String -> (Prog -> [(String,a)] -> a) -> Analysis a
dependencyModuleAnalysis anaName anaFunc =
DependencyModuleAnalysis anaName anaFunc
-------------------------------------------------------------------------
--- Is the analysis a simple analysis?
--- Otherwise, it is a dependency analysis which requires a fixpoint
--- computation to compute the results.
isSimpleAnalysis :: Analysis a -> Bool
isSimpleAnalysis analysis = case analysis of
SimpleFuncAnalysis _ _ -> True
SimpleTypeAnalysis _ _ -> True
SimpleConstructorAnalysis _ _ -> True
SimpleFuncAnalysis _ _ -> True
SimpleTypeAnalysis _ _ -> True
SimpleConstructorAnalysis _ _ -> True
CombinedSimpleFuncAnalysis _ _ _ _ -> True
CombinedSimpleTypeAnalysis _ _ _ _ -> True
_ -> False
_ -> False
--- Is the analysis a combined analysis?
isCombinedAnalysis :: Analysis a -> Bool
......@@ -180,30 +203,32 @@ isCombinedAnalysis analysis = case analysis of
CombinedSimpleTypeAnalysis _ _ _ _ -> True
CombinedDependencyFuncAnalysis _ _ _ _ _ -> True
CombinedDependencyTypeAnalysis _ _ _ _ _ -> True
_ -> False
_ -> False
--- Is the analysis a function analysis?
--- Otherwise, it is a type or constructor analysis.
isFunctionAnalysis :: Analysis a -> Bool
isFunctionAnalysis analysis = case analysis of
SimpleFuncAnalysis _ _ -> True
DependencyFuncAnalysis _ _ _ -> True
CombinedSimpleFuncAnalysis _ _ _ _ -> True
SimpleFuncAnalysis _ _ -> True
DependencyFuncAnalysis _ _ _ -> True
CombinedSimpleFuncAnalysis _ _ _ _ -> True
CombinedDependencyFuncAnalysis _ _ _ _ _ -> True
_ -> False
_ -> False
--- Name of the analysis to be used in server communication and
--- analysis files.
analysisName :: Analysis a -> String
analysisName (SimpleFuncAnalysis name _) = name
analysisName (SimpleTypeAnalysis name _) = name
analysisName (SimpleConstructorAnalysis name _) = name
analysisName (DependencyFuncAnalysis name _ _) = name
analysisName (DependencyTypeAnalysis name _ _) = name
analysisName (SimpleFuncAnalysis name _ ) = name
analysisName (SimpleTypeAnalysis name _ ) = name
analysisName (SimpleConstructorAnalysis name _ ) = name
analysisName (DependencyFuncAnalysis name _ _) = name
analysisName (DependencyTypeAnalysis name _ _) = name
analysisName (CombinedSimpleFuncAnalysis _ nameB _ _) = nameB
analysisName (CombinedSimpleTypeAnalysis _ nameB _ _) = nameB
analysisName (CombinedDependencyFuncAnalysis _ nameB _ _ _) = nameB
analysisName (CombinedDependencyTypeAnalysis _ nameB _ _ _) = nameB
analysisName (SimpleModuleAnalysis name _) = name
analysisName (DependencyModuleAnalysis name _) = name
--- Names of the base analyses of a combined analysis.
baseAnalysisNames :: Analysis a -> [String]
......
------------------------------------------------------------------------
--- An analysis which returns information whether a module is unsafe, i.e.,
--- it imports directly or indirectly the module `Unsafe`.
---
--- @author Michael Hanus
--- @version June 2018
------------------------------------------------------------------------
module Analysis.UnsafeModule ( showUnsafe, unsafeModuleAnalysis )
where
import List ( nub )
import Analysis.Types
import FlatCurry.Goodies ( progImports, progName )
import FlatCurry.Types
------------------------------------------------------------------------
--- This analysis associates to a module the of all module names
--- which directly imports the module `Unsafe`.
--- Such modules might hide dangerous operations in
--- purely functional operations.
--- Thus, a module is safe if the analysis result is the empty list.
unsafeModuleAnalysis :: Analysis [String]
unsafeModuleAnalysis = dependencyModuleAnalysis "UnsafeModule" importsUnsafe
-- Show a list of type constructor names as a string.
showUnsafe :: AOutFormat -> [String] -> String
showUnsafe _ [] = "safe"
showUnsafe ANote (_:_) = "unsafe"
showUnsafe AText [mod] = "unsafe (due to module " ++ mod ++ ")"
showUnsafe AText ms@(_:_:_) = "unsafe (due to modules " ++ unwords ms ++ ")"
-- Does the module import the module `Unsafe` or any other unsafe module?
-- TODO: to be real safe, one also has to check external operations!
importsUnsafe :: Prog -> [(String,[String])] -> [String]
importsUnsafe prog impinfos =
let unsafemods = (if "Unsafe" `elem` progImports prog then [progName prog]
else []) ++
concatMap snd impinfos
in nub unsafemods
-----------------------------------------------------------------------
Analyzing module for importing `Unsafe` module
----------------------------------------------
The `UnsafeModule` analysis returns information whether a module is unsafe,
i.e., it imports directly or indirectly the module `Unsafe`.
Such modules might hide dangerous operations in
purely functional operations.
The result of this analysis is the list of the names of all modules
which directly imports the module `Unsafe`.
Thus, a module is safe if the analysis result is the empty list.
......@@ -34,7 +34,8 @@ import CASS.PackageConfig (packagePath, packageExecutable, packageVersion)
systemBanner :: String
systemBanner =
let bannerText = "CASS: Curry Analysis Server System (Version " ++
packageVersion ++ " of 23/01/2017 for "++curryCompiler++")"
packageVersion ++ " of 05/06/2018 for " ++
curryCompiler ++ ")"
bannerLine = take (length bannerText) (repeat '=')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......
......@@ -46,6 +46,7 @@ import Analysis.SolutionCompleteness
import Analysis.Termination
import Analysis.TotallyDefined
import Analysis.TypeUsage
import Analysis.UnsafeModule
--------------------------------------------------------------------
--- Each analysis used in our tool must be registered in this list
......@@ -79,10 +80,10 @@ registeredAnalysis =
,cassAnalysis "Root replacements" rootReplAnalysis showRootRepl
,cassAnalysis "Terminating operations" terminationAnalysis showTermination
,cassAnalysis "Types in values" typesInValuesAnalysis showTypeNames
,cassAnalysis "Unsafe module" unsafeModuleAnalysis showUnsafe
]
--------------------------------------------------------------------
-- Static part of this module follows below
--------------------------------------------------------------------
......
......@@ -3,22 +3,18 @@
--- In particular, it contains some simple fixpoint computations.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version January 2017
--- @version June 2018
--------------------------------------------------------------------------
module CASS.WorkerFunctions where
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import ReadShowTerm(readQTerm,showQTerm)
import List(partition)
import IOExts
import System(getCPUTime)
import Maybe(fromJust)
import FiniteMap
import IOExts
import List ( partition )
import Maybe ( fromJust )
import SCC ( scc )
import SetRBT
import SCC(scc)
import System ( getCPUTime )
import Analysis.Files
import Analysis.Logging ( debugMessage, debugString )
......@@ -26,9 +22,13 @@ import Analysis.Types ( Analysis(..), isSimpleAnalysis, isCombinedAnalysis
, analysisName, startValue)
import Analysis.ProgInfo ( ProgInfo, combineProgInfo, emptyProgInfo
, publicProgInfo, lookupProgInfo, lists2ProgInfo
,equalProgInfo, showProgInfo )
, equalProgInfo, publicListFromProgInfo, showProgInfo )
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import CASS.Configuration
import CASS.FlatCurryDependency( callsDirectly, dependsDirectlyOnTypes )
import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes )
-----------------------------------------------------------------------
-- Datatype to store already read ProgInfos for modules.
......@@ -171,17 +171,17 @@ execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod =
-----------------------------------------------------------------------
--- Run an analysis but load default values (e.g., for external operations)
--- before and do not analyse the operations or type for these defaults.
--- before and do not analyse the operations or types for these defaults.
runAnalysis :: Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
-> IO (ProgInfo a)
runAnalysis analysis prog importInfos startvals fpmethod = do
deflts <- loadDefaultAnalysisValues (analysisName analysis) (progName prog)
let defaultFuncs =
updProgFuncs (filter (\fd -> funcName fd `elem` map fst deflts)) prog
updProgFuncs (filter (\fd -> funcName fd `elem` map fst deflts)) prog
definedFuncs =
updProgFuncs (filter (\fd -> funcName fd `notElem` map fst deflts)) prog
defaultTypes =
updProgTypes (filter (\fd -> typeName fd `elem` map fst deflts)) prog
updProgTypes (filter (\fd -> typeName fd `elem` map fst deflts)) prog
definedTypes =
updProgTypes (filter (\fd -> typeName fd `notElem` map fst deflts)) prog
let (progWithoutDefaults,defaultproginfo) = case analysis of
......@@ -196,17 +196,39 @@ runAnalysis analysis prog importInfos startvals fpmethod = do
(definedFuncs, funcInfos2ProgInfo defaultFuncs deflts)
DependencyTypeAnalysis _ _ _ ->
(definedTypes, typeInfos2ProgInfo defaultTypes deflts)
SimpleModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError
DependencyModuleAnalysis _ _ ->
if null deflts then (definedFuncs, emptyProgInfo)
else error defaultNotEmptyError
_ -> error "Internal error in WorkerFunctions.runAnalysis"
let result = executeAnalysis analysis progWithoutDefaults
(combineProgInfo importInfos defaultproginfo)
startvals fpmethod
return $ combineProgInfo defaultproginfo result
where
defaultNotEmptyError = "Default analysis information for analysis '" ++
analysisName analysis ++ "' and module '" ++
progName prog ++ "' not empty!"
--- Executes an anlysis on a given program w.r.t. an imported ProgInfo
--- and some start values (for dependency analysis).
--- The fixpoint iteration method to be applied is passed as the last argument.
executeAnalysis :: Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
-> ProgInfo a
-- The results of a module analysis for module `m` are encoded as
-- a `ProgInfo` with a single entry for the qualified name `m.m`.
executeAnalysis (SimpleModuleAnalysis _ anaFunc) prog _ _ _ =
let pname = progName prog
in lists2ProgInfo ([((pname,pname), anaFunc prog)], [])
executeAnalysis (DependencyModuleAnalysis _ anaFunc) prog impproginfos _ _ =
let pname = progName prog
importinfos = map (\ (qn,a) -> (fst qn,a))
(publicListFromProgInfo impproginfos)
in lists2ProgInfo ([((pname,pname), anaFunc prog importinfos)], [])
executeAnalysis (SimpleFuncAnalysis _ anaFunc) prog _ _ _ =
(lists2ProgInfo . map2 (\func -> (funcName func, anaFunc func))
. partition isVisibleFunc . progFuncs) prog
......
......@@ -5,7 +5,7 @@
--- might be changed in the future!
---
--- @author Michael Hanus
--- @version September 2017
--- @version June 2018
------------------------------------------------------------------------------
module XML(XmlExp(..),Encoding(..),XmlDocParams(..),
......@@ -278,7 +278,8 @@ parseXmlString s = fst (parseXmlTokens (scanXmlString s) Nothing)
-- parse a list of XML tokens into list of XML expressions:
-- parseXmlTokens tokens stoptoken = (xml_expressions, remaining_tokens)
parseXmlTokens :: [XmlExp] -> Maybe String -> ([XmlExp],[XmlExp])
parseXmlTokens [] Nothing = ([],[])
parseXmlTokens [] Nothing = ([],[])
parseXmlTokens [] (Just _) = error "XML.parseXmlTokens: incomplete parse"
parseXmlTokens (XText s : xtokens) stop =
let (xexps, rem_xtokens) = parseXmlTokens xtokens stop
in (XText (xmlUnquoteSpecials s) : xexps, rem_xtokens)
......@@ -294,6 +295,8 @@ parseXmlTokens (XElem (t:ts) args cont : xtokens) stop
in (XElem ts args cont : xexps, rem_xtokens)
| otherwise = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop
in (XElem (t:ts) args cont : xexps, rem_xtokens)
parseXmlTokens (XElem [] _ _ : _) _ =
error "XML.parseXmlTokens: incomplete parse"
-- scan an XML string into list of XML tokens:
......
......@@ -67,7 +67,7 @@ getInterfaceInfos anaName (mod:mods) =
loadDefaultAnalysisValues :: String -> String -> IO [(QName,a)]
loadDefaultAnalysisValues anaName moduleName = do
(_,fileName) <- findModuleSourceInLoadPath moduleName
let defaultFileName = stripCurrySuffix fileName ++ ".defaults."++anaName
let defaultFileName = stripCurrySuffix fileName ++ ".defaults." ++ anaName
fileExists <- doesFileExist defaultFileName
if fileExists
then do debugMessage 3 ("Load default values from " ++ defaultFileName)
......
......@@ -10,7 +10,7 @@
--- (instead of the data constructors).
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version March 2017
--- @version June 2018
-------------------------------------------------------------------------
module Analysis.Types
......@@ -20,12 +20,13 @@ module Analysis.Types
, combinedSimpleFuncAnalysis, combined2SimpleFuncAnalysis
, combinedSimpleTypeAnalysis
, combinedDependencyFuncAnalysis, combinedDependencyTypeAnalysis
, simpleModuleAnalysis, dependencyModuleAnalysis
, isSimpleAnalysis, isCombinedAnalysis, isFunctionAnalysis
, analysisName, baseAnalysisNames, startValue
, AOutFormat(..)
) where
import FlatCurry.Types ( ConsDecl, FuncDecl, TypeDecl, QName )
import FlatCurry.Types ( Prog, ConsDecl, FuncDecl, TypeDecl, QName )
import FlatCurry.Goodies ( progImports )
import Analysis.ProgInfo ( ProgInfo, combineProgInfo, lookupProgInfo )
......@@ -49,6 +50,8 @@ data Analysis a =
(String -> IO (FuncDecl -> [(QName,a)] -> a))
| CombinedDependencyTypeAnalysis [String] String Bool a
(String -> IO (TypeDecl -> [(QName,a)] -> a))
| SimpleModuleAnalysis String (Prog -> a)
| DependencyModuleAnalysis String (Prog -> [(String,a)] -> a)
--- A simple analysis for functions takes an operation that computes
......@@ -160,18 +163,38 @@ combinedDependencyTypeAnalysis ananame baseAnalysis startval anaType =
[analysisName baseAnalysis] ananame True startval
(runWithBaseAnalysis baseAnalysis anaType)
--- Construct a simple analysis for entire modules.
--- The analysis has a name and takes an operation that computes
--- some information from a given module.
simpleModuleAnalysis :: String -> (Prog -> a) -> Analysis a
simpleModuleAnalysis anaName anaFunc =
SimpleModuleAnalysis anaName anaFunc
--- Construct a module analysis which uses analysis information on
--- imported modules.
--- The analysis has a name and an operation to analyze a module.
--- The analysis operation could use already computed information
--- of imported modules, represented as a list of module name/information pairs.
--- Note that a fixpoint iteration is not necessary
--- since module dependencies must be acyclic.
dependencyModuleAnalysis :: String -> (Prog -> [(String,a)] -> a) -> Analysis a
dependencyModuleAnalysis anaName anaFunc =
DependencyModuleAnalysis anaName anaFunc
-------------------------------------------------------------------------
--- Is the analysis a simple analysis?
--- Otherwise, it is a dependency analysis which requires a fixpoint
--- computation to compute the results.
isSimpleAnalysis :: Analysis a -> Bool
isSimpleAnalysis analysis = case analysis of
SimpleFuncAnalysis _ _ -> True
SimpleTypeAnalysis _ _ -> True
SimpleConstructorAnalysis _ _ -> True
SimpleFuncAnalysis _ _ -> True
SimpleTypeAnalysis _ _ -> True
SimpleConstructorAnalysis _ _ -> True
CombinedSimpleFuncAnalysis _ _ _ _ -> True
CombinedSimpleTypeAnalysis _ _ _ _ -> True