Commit 4c36b254 authored by Michael Hanus's avatar Michael Hanus
Browse files

CPM updated

parent ff28616c
...@@ -126,7 +126,7 @@ to pull down a copy of the central package index to your system. ...@@ -126,7 +126,7 @@ to pull down a copy of the central package index to your system.
You can use the same command to update later You can use the same command to update later
your copy of the central package index to the newest version. your copy of the central package index to the newest version.
Afterwards, you can show a short list of all packages in this index by Afterwards, you can show a list of all packages in this index by
% %
\begin{lstlisting} \begin{lstlisting}
> cypm list > cypm list
...@@ -474,10 +474,18 @@ changes when compared to the previous version $1.2.6$, you can use the ...@@ -474,10 +474,18 @@ changes when compared to the previous version $1.2.6$, you can use the
CPM will then check the types of all public functions and data types in all CPM will then check the types of all public functions and data types in all
exported modules of both versions (see the \code{exportedModules} field of the exported modules of both versions (see the \code{exportedModules} field of the
package specification) and report any differences and whether they violate package specification) and report any differences and whether they violate
semantic versioning. It will also generate a CurryCheck program that will semantic versioning.
compare the behavior of all exported functions in all exported modules whose CPM will also compare the behavior of all exported functions
types have not changed and execute that program. Note that not all functions in all exported modules whose types have not changed.
can be compared via CurryCheck. Actually, this part is performed by CurryCheck \cite{Hanus16LOPSTR},
a property-based test tool for Curry.
For this purpose, CPM generates a Curry program containing
properties stating the equivalence
of two operations with the same name but defined in two different
versions of a package.
The ideas and scheme of this generation process are
described in \cite{Hanus17ICLP}.
Note that not all functions can be compared via CurryCheck.
In particular, functions taking other functions as arguments In particular, functions taking other functions as arguments
(there are a few other minor restrictions) (there are a few other minor restrictions)
can not be checked so that CPM automatically excludes them from checking. can not be checked so that CPM automatically excludes them from checking.
...@@ -537,6 +545,27 @@ In this case, one can mark those functions with the compiler pragma ...@@ -537,6 +545,27 @@ In this case, one can mark those functions with the compiler pragma
\verb|{-# NOCOMPARE -#}| \verb|{-# NOCOMPARE -#}|
so that CPM will not generate tests for them. so that CPM will not generate tests for them.
Note that there are different ways to state the equivalence of operations
(e.g., see the discussion in \cite{BacciEtAl12}).
CPM offers two kinds of equivalence tests:
\begin{itemize}
\item
\emph{Ground equivalence} means that two operations are considered
as equivalent if they yield identical values for identical input values.
\item
\emph{Contextual or full equivalence} means that two operations
are considered as equivalent if they produce the same results
in all possible contexts.
\end{itemize}
%
Since contextual equivalence is more meaningful in the context
of semantic versioning, CPM tests this kind of
equivalence in the default case, based on the techniques
described in \cite{AntoyHanus18FLOPS}.
However, using the option \code{--ground} of the \code{diff} command,
one can also enfore the checking of ground equivalence
as described in \cite{Hanus17ICLP}.
\subsection{Adding Packages to the Central Package Index} \subsection{Adding Packages to the Central Package Index}
\label{sec:adding-a-package} \label{sec:adding-a-package}
...@@ -963,9 +992,10 @@ If the version option is missing, the latest version of the current package ...@@ -963,9 +992,10 @@ If the version option is missing, the latest version of the current package
found in the repository is used for comparison. found in the repository is used for comparison.
If the options \code{--api-only} or \code{--behavior-only} are added, If the options \code{--api-only} or \code{--behavior-only} are added,
then only the API or the behavior are compared, respectively. then only the API or the behavior are compared, respectively.
Using the option \code{--modules}, one can also specify a comma-separated In the default case, all modules commonly exported by both
list of module names to be compared. Without this option, versions of the package are compared.
all exported modules are compared. Using the option \code{--modules}, one can restrict this comparison
to a list of modules specified by a comma-separated list of module names.
As described in Section~\ref{sec:semantic-versioning}, As described in Section~\ref{sec:semantic-versioning},
CPM uses property tests to compare the behavior CPM uses property tests to compare the behavior
...@@ -977,6 +1007,12 @@ but then you have to ensure that all operations are terminating ...@@ -977,6 +1007,12 @@ but then you have to ensure that all operations are terminating
(or you can annotate them by pragmas, (or you can annotate them by pragmas,
see Section~\ref{sec:semantic-versioning}). see Section~\ref{sec:semantic-versioning}).
In the default case, CPM tests the contextual equivalence of
operations (see Section~\ref{sec:semantic-versioning}).
With the option \code{--ground}, the ground equivalence of operations
is tested.
\item[\fbox{\code{exec $command$}}] Executes an arbitrary command with the \item[\fbox{\code{exec $command$}}] Executes an arbitrary command with the
\code{CURRYPATH} environment variable set to the paths of all dependencies of \code{CURRYPATH} environment variable set to the paths of all dependencies of
the current package. the current package.
...@@ -1374,6 +1410,36 @@ You can simply re-install the newest version of this index ...@@ -1374,6 +1410,36 @@ You can simply re-install the newest version of this index
by the command \code{cypm update}. by the command \code{cypm update}.
\end{description} \end{description}
\newpage
\begin{thebibliography}{1}
\bibitem{AntoyHanus18FLOPS}
S.~Antoy and M.~Hanus.
\newblock Equivalence Checking of Non-deterministic Operations.
\newblock In {\em Proc. of the 14th International Symposium on Functional and
Logic Programming (FLOPS 2018)}, pp. 149--165. Springer LNCS 10818, 2018.
\bibitem{BacciEtAl12}
G.~Bacci, M.~Comini, M.A. Feli{\'u}, and A.~Villanueva.
\newblock Automatic Synthesis of Specifications for First Order {Curry}.
\newblock In {\em Principles and Practice of Declarative Programming
(PPDP'12)}, pp. 25--34. ACM Press, 2012.
\bibitem{Hanus16LOPSTR}
M.~Hanus.
\newblock {CurryCheck}: Checking Properties of {Curry} Programs.
\newblock In {\em Proceedings of the 26th International Symposium on
Logic-Based Program Synthesis and Transformation (LOPSTR 2016)}, pp.
222--239. Springer LNCS 10184, 2017.
\bibitem{Hanus17ICLP}
M.~Hanus.
\newblock Semantic Versioning Checking in a Declarative Package Manager.
\newblock In {\em Technical Communications of the 33rd International Conference
on Logic Programming (ICLP 2017)}, OpenAccess Series in Informatics (OASIcs),
pp. 6:1--6:16. Schloss Dagstuhl - Leibniz-Zentrum fuer Informatik, 2017.
\end{thebibliography}
\end{document} \end{document}
......
...@@ -67,7 +67,18 @@ readAbstractCurryFromPackagePath pkg pkgDir deps modname = do ...@@ -67,7 +67,18 @@ readAbstractCurryFromPackagePath pkg pkgDir deps modname = do
acyName <- return $ case src of acyName <- return $ case src of
Nothing -> error $ "Module not found: " ++ modname Nothing -> error $ "Module not found: " ++ modname
Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy" Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy"
readAbstractCurryFile acyName readAbstractCurryFile acyName >>= return . addPrimTypes
where
-- work-around for missing Prelude.Char|Int|Float declarations:
addPrimTypes p@(CurryProg mname imports dfltdecl clsdecls instdecls
typedecls funcdecls opdecls)
| mname == pre && primType "Int" `notElem` typedecls
= CurryProg mname imports dfltdecl clsdecls instdecls
(map primType ["Int","Float","Char"] ++ typedecls)
funcdecls opdecls
| otherwise = p
where pre = "Prelude"
primType n = CType ("Prelude",n) Public [] [] []
--- Reads an AbstractCurry module from a package or one of its dependencies. --- Reads an AbstractCurry module from a package or one of its dependencies.
--- ---
......
...@@ -97,18 +97,20 @@ compareModulesFromPackageAndDir cfg repo gc dirA nameB verB onlyMods = ...@@ -97,18 +97,20 @@ compareModulesFromPackageAndDir cfg repo gc dirA nameB verB onlyMods =
compareModulesInDirs :: Config -> Repository -> GC.GlobalCache -> String compareModulesInDirs :: Config -> Repository -> GC.GlobalCache -> String
-> String -> Maybe [String] -> String -> Maybe [String]
-> IO (ErrorLogger [(String, Differences)]) -> IO (ErrorLogger [(String, Differences)])
compareModulesInDirs cfg repo gc dirA dirB onlyMods = loadPackageSpec dirA |>= compareModulesInDirs cfg repo gc dirA dirB onlyMods =
\pkgA -> loadPackageSpec dirB |>= loadPackageSpec dirA |>= \pkgA ->
\pkgB -> resolveAndCopyDependencies cfg repo gc dirA |>= loadPackageSpec dirB |>= \pkgB ->
\depsA -> resolveAndCopyDependencies cfg repo gc dirB |>= resolveAndCopyDependencies cfg repo gc dirA |>= \depsA ->
\depsB -> mapEL (compareApiModule pkgA dirA depsA pkgB dirB depsB) resolveAndCopyDependencies cfg repo gc dirB |>= \depsB ->
(allMods pkgA pkgB) |>= let cmpmods = nub (exportedModules pkgA ++ exportedModules pkgB) in
\diffs -> let modsWithDiffs = zip (allMods pkgA pkgB) diffs in if null cmpmods
succeedIO $ case onlyMods of then log Info "No exported modules to compare" |> succeedIO []
Nothing -> modsWithDiffs else
Just ms -> filter ((`elem` ms) . fst) modsWithDiffs mapEL (compareApiModule pkgA dirA depsA pkgB dirB depsB) cmpmods |>=
where \diffs -> let modsWithDiffs = zip cmpmods diffs in
allMods a b = nub $ (exportedModules a) ++ (exportedModules b) succeedIO $ case onlyMods of
Nothing -> modsWithDiffs
Just ms -> filter ((`elem` ms) . fst) modsWithDiffs
--- Compares a single module from two package versions. --- Compares a single module from two package versions.
--- ---
......
-------------------------------------------------------------------------------- -------------------------------------------------------------------------------
--- This module contains functions that compare the behavior of two versions of --- This module contains functions that compare the behavior of two versions of
--- a package. --- a package.
---
--- For this purpose, copies of these packages and a main "comparison"
--- module (with name "Compare") are generated in the temporary
--- directory `/tmp/CPM/bdiff` and then CurryCheck is executed on `Compare`.
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module CPM.Diff.Behavior module CPM.Diff.Behavior
...@@ -128,16 +132,16 @@ data ComparisonInfo = ComparisonInfo ...@@ -128,16 +132,16 @@ data ComparisonInfo = ComparisonInfo
--- Create temporary directory for the behavior diff. --- Create temporary directory for the behavior diff.
createBaseTemp :: IO (ErrorLogger String) createBaseTemp :: IO (ErrorLogger String)
createBaseTemp = getTemporaryDirectory >>= createBaseTemp = do
\tmpDir -> tmpDir <- getTemporaryDirectory
let let tmp = tmpDir </> "CPM" </> "bdiff"
tmp = tmpDir </> "CPM" </> "bdiff" recreateDirectory tmp >> succeedIO tmp
in recreateDirectory tmp >> succeedIO tmp
--- Get temporary directory for the behavior diff. --- Get temporary directory for the behavior diff.
getBaseTemp :: IO (ErrorLogger String) getBaseTemp :: IO (ErrorLogger String)
getBaseTemp = getTemporaryDirectory >>= getBaseTemp = do
\tmpDir -> succeedIO $ tmpDir </> "CPM" </> "bdiff" tmpDir <- getTemporaryDirectory
succeedIO $ tmpDir </> "CPM" </> "bdiff"
--- This message is printed before CurryCheck is executed. --- This message is printed before CurryCheck is executed.
infoText :: String infoText :: String
...@@ -152,6 +156,7 @@ infoText = unlines ...@@ -152,6 +156,7 @@ infoText = unlines
--- @param repo - the central package index --- @param repo - the central package index
--- @param gc - the global package cache --- @param gc - the global package cache
--- @param info - the comparison info obtained from preparePackageDirs --- @param info - the comparison info obtained from preparePackageDirs
--- @param groundequiv - test ground equivalence only?
--- @param useanalysis - use program analysis to filter non-term. operations? --- @param useanalysis - use program analysis to filter non-term. operations?
--- @param mods - a list of modules to compare --- @param mods - a list of modules to compare
diffBehavior :: Config diffBehavior :: Config
...@@ -159,16 +164,19 @@ diffBehavior :: Config ...@@ -159,16 +164,19 @@ diffBehavior :: Config
-> GC.GlobalCache -> GC.GlobalCache
-> ComparisonInfo -> ComparisonInfo
-> Bool -> Bool
-> Bool
-> Maybe [String] -> Maybe [String]
-> IO (ErrorLogger ()) -> IO (ErrorLogger ())
diffBehavior cfg repo gc info useanalysis cmods = getBaseTemp |>= diffBehavior cfg repo gc info groundequiv useanalysis cmods =
\baseTmp -> findFunctionsToCompare cfg repo gc (infSourceDirA info) getBaseTemp |>= \baseTmp ->
(infSourceDirB info) useanalysis cmods |>= findFunctionsToCompare cfg repo gc (infSourceDirA info) (infSourceDirB info)
useanalysis cmods |>=
\(acyCache, loadpath, funcs, removed) -> \(acyCache, loadpath, funcs, removed) ->
let let
filteredFuncs = maybe funcs filteredFuncs =
(\mods -> filter ((`elem` mods) . fst . funcName . snd) funcs) maybe funcs
cmods (\mods -> filter ((`elem` mods) . fst . funcName . snd) funcs)
cmods
filteredNames = map snd filteredFuncs filteredNames = map snd filteredFuncs
in log Debug ("Filtered operations to be checked: " ++ in log Debug ("Filtered operations to be checked: " ++
showFuncNames filteredNames) |> showFuncNames filteredNames) |>
...@@ -179,7 +187,8 @@ diffBehavior cfg repo gc info useanalysis cmods = getBaseTemp |>= ...@@ -179,7 +187,8 @@ diffBehavior cfg repo gc info useanalysis cmods = getBaseTemp |>=
printRemoved removed printRemoved removed
putStrLn $ putStrLn $
"Comparing operations " ++ showFuncNames filteredNames ++ "\n" "Comparing operations " ++ showFuncNames filteredNames ++ "\n"
genCurryCheckProgram cfg repo gc filteredFuncs info acyCache loadpath genCurryCheckProgram cfg repo gc filteredFuncs info groundequiv
acyCache loadpath
|> callCurryCheck cfg info baseTmp |> callCurryCheck cfg info baseTmp
where where
printRemoved removed = printRemoved removed =
...@@ -227,16 +236,17 @@ genCurryCheckProgram :: Config ...@@ -227,16 +236,17 @@ genCurryCheckProgram :: Config
-> Repository -> Repository
-> GC.GlobalCache -> GC.GlobalCache
-> [(Bool,CFuncDecl)] -> [(Bool,CFuncDecl)]
-> ComparisonInfo -> ComparisonInfo
-> Bool
-> ACYCache -> [String] -> ACYCache -> [String]
-> IO (ErrorLogger ()) -> IO (ErrorLogger ())
genCurryCheckProgram cfg repo gc prodfuncs info acyCache loadpath = genCurryCheckProgram cfg repo gc prodfuncs info groundequiv acyCache loadpath =
getBaseTemp |>= \baseTmp -> getBaseTemp |>= \baseTmp ->
let translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info in let translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info in
foldEL translatorGenerator (acyCache, emptyTrans) foldEL translatorGenerator (acyCache, emptyTrans)
translateTypes |>= \(_, transMap) -> translateTypes |>= \(_, transMap) ->
let (limittypes,testFunctions) = unzip (map (genTestFunction info transMap) let (limittypes,testFunctions) =
prodfuncs) unzip (map (genTestFunction info groundequiv transMap) prodfuncs)
transFunctions = transFuncs transMap transFunctions = transFuncs transMap
limittconss = nub (concatMap tconsOfType (concat limittypes)) limittconss = nub (concatMap tconsOfType (concat limittypes))
limittcmods = nub (map fst limittconss) limittcmods = nub (map fst limittconss)
...@@ -247,7 +257,9 @@ genCurryCheckProgram cfg repo gc prodfuncs info acyCache loadpath = ...@@ -247,7 +257,9 @@ genCurryCheckProgram cfg repo gc prodfuncs info acyCache loadpath =
limittcmods limittcmods
let limitFunctions = concatMap (genLimitFunction typeinfos) limittdecls let limitFunctions = concatMap (genLimitFunction typeinfos) limittdecls
prog = simpleCurryProg "Compare" imports [] prog = simpleCurryProg "Compare" imports []
(testFunctions ++ transFunctions ++ limitFunctions) [] (concat testFunctions ++ transFunctions ++
(if groundequiv then limitFunctions else []))
[]
let prodops = map snd (filter fst prodfuncs) let prodops = map snd (filter fst prodfuncs)
unless (null prodops) $ putStrLn $ unless (null prodops) $ putStrLn $
"Productive operations (currently not fully supported for all types):\n" ++ "Productive operations (currently not fully supported for all types):\n" ++
...@@ -338,42 +350,69 @@ genLimitFunction typeinfos tdecl = case tdecl of ...@@ -338,42 +350,69 @@ genLimitFunction typeinfos tdecl = case tdecl of
--- Generates a test function to compare two versions of the given function. --- Generates a test function to compare two versions of the given function.
--- If the argument and result types must be transformed between types
--- of the two different version, also auxiliary operations are generated
--- for the equivalence test.
--- If the function is productive, we also return the result type of --- If the function is productive, we also return the result type of
--- the function in order to generate "limit" functions for this type. --- the function in order to generate "limit" functions for this type.
genTestFunction :: ComparisonInfo -> TransMap -> (Bool, CFuncDecl) genTestFunction :: ComparisonInfo -> Bool -> TransMap -> (Bool, CFuncDecl)
-> ([CTypeExpr], CFuncDecl) -> ([CTypeExpr], [CFuncDecl])
genTestFunction info tm (isprod,f) = genTestFunction info groundequiv tm (isprod,f) =
(if isprod then [newResultType] else [], (if isprod && groundequiv then [newResultTypeA] else [],
stCmtFunc ("Check equivalence of operation " ++ fmod ++ "." ++ fname ++ if groundequiv
if isprod then " up to a depth limit" else "") then
(modName, testName) (realArity f) Private newType [stCmtFunc ("Check ground equivalence of operation " ++ fmod ++ "." ++
[if isprod fname ++ if isprod then " up to a depth limit" else "")
then let limitvar = (100,"limit") in (modName, testName ++ "_GroundEquiv") (realArity f) Private newType
simpleRule (if isprod then CPVar limitvar : vars else vars) [if isprod
(applyF ("Test.EasyCheck", "<~>") then let limitvar = (100,"limit") in
[applyE (type2LimitFunc newResultType) [CVar limitvar, callA], simpleRule (if isprod then CPVar limitvar : vars else vars)
applyE (type2LimitFunc newResultType) [CVar limitvar, callB]]) (applyF (easyCheckMod "<~>")
else simpleRule vars (applyF ("Test.EasyCheck", "<~>") [callA, callB])]) [applyE (type2LimitFunc newResultTypeA)
[CVar limitvar, callA],
applyE (type2LimitFunc newResultTypeA)
[CVar limitvar, callB]])
else simpleRule vars (applyF (easyCheckMod "<~>") [callA, callB])]
]
else
[stFunc testName1 (realArity f) Private
(replaceResultType newType newResultTypeB)
[simpleRule vars callA]
,stFunc testName2 (realArity f) Private
(replaceResultType newType newResultTypeB)
[simpleRule vars callB]
,stCmtFunc ("Check equivalence of operation " ++ fmod ++ "." ++ fname)
(modName, testName ++ "_Equivalent") 0 Private
(baseType (easyCheckMod "Prop"))
[simpleRule [] (applyF (easyCheckMod "<=>")
[constF testName1, constF testName2])]]
)
where where
(fmod,fname) = funcName f (fmod,fname) = funcName f
modName = "Compare" modName = "Compare"
testName = "test_" ++ testName = "test_" ++
combineTuple (both (replace' '.' '_') $ (fmod, encodeCurryId fname)) "_" combineTuple (both (replace' '.' '_') $ (fmod, encodeCurryId fname)) "_"
testName1 = (modName, testName++"_1")
testName2 = (modName, testName++"_2")
vars = pVars (realArity f) vars = pVars (realArity f)
modA = (infPrefixA info) ++ "_" ++ fmod modA = infPrefixA info ++ "_" ++ fmod
modB = (infPrefixB info) ++ "_" ++ fmod modB = infPrefixB info ++ "_" ++ fmod
instantiatedFunc = instantiateBool $ typeOfQualType $ funcType f instantiatedFunc = instantiateBool $ typeOfQualType $ funcType f
newResultType = mapTypes info newResultTypeA = mapTypes (infModMapA info)
(instantiateBool (resultType (typeOfQualType (funcType f)))) (instantiateBool (resultType (typeOfQualType (funcType f))))
newType = let ftype = mapTypes info $ genTestFuncType f newResultTypeB = mapTypes (infModMapB info)
(instantiateBool (resultType (typeOfQualType (funcType f))))
newType = let ftype = mapTypes (infModMapA info) $ genTestFuncType f
in if isprod then baseType ("Nat","Nat") ~> ftype in if isprod then baseType ("Nat","Nat") ~> ftype
else ftype else ftype
returnTransform = case findTrans tm (resultType $ instantiatedFunc) of returnTransform = case findTrans tm (resultType $ instantiatedFunc) of
Nothing -> id Nothing -> id
Just tr -> \t -> applyF (modName, tr) [t] Just tr -> \t -> applyF (modName, tr) [t]
-- Since we use the data types from the A version in type of the generated -- Since we use the data types from the A version in type of the generated
-- test function, we transform the parameters in the call of the B version of -- test function, we transform the parameters in the call of the B version of
-- the tested function using the translator functions from the TransMap. As we -- the tested function using the translator functions from the TransMap. As we
...@@ -392,7 +431,7 @@ genTestFunction info tm (isprod,f) = ...@@ -392,7 +431,7 @@ genTestFunction info tm (isprod,f) =
(_, CPVar v) -> (_, CPVar v) ->
maybe (CVar v) maybe (CVar v)
(\_ -> case findTrans tm texp of (\_ -> case findTrans tm texp of
Just n -> applyF ("Compare", n) [CVar v] Just n -> applyF (modName, n) [CVar v]
Nothing -> CVar v) Nothing -> CVar v)
(tconsArgsOfType texp) (tconsArgsOfType texp)
_ -> error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach" _ -> error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
...@@ -521,9 +560,14 @@ genTranslatorFunction :: Config ...@@ -521,9 +560,14 @@ genTranslatorFunction :: Config
-> CTypeExpr -> CTypeExpr
-> IO (ErrorLogger (ACYCache, TransMap)) -> IO (ErrorLogger (ACYCache, TransMap))
genTranslatorFunction cfg repo gc info acy tm texp = genTranslatorFunction cfg repo gc info acy tm texp =
-- TODO: generate also translation functions for functional types.
-- This requires type translator in both directions but currently
-- we generate only one direction.
-- For instance, to translate a function A->B into A'->B':
-- (A->B)2(A'->B') f = \x -> B2B' (f (A'2A x))
let (mod, n) = maybe let (mod, n) = maybe
(error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++ (error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++
"Cannot generate translator function for type:\n" ++ "cannot generate type translation function for type:\n" ++
pPrint (ppCTypeExpr defaultOptions texp)) pPrint (ppCTypeExpr defaultOptions texp))
fst fst
(tconsArgsOfType texp) (tconsArgsOfType texp)
...@@ -673,15 +717,18 @@ instantiate tdecl texp = case texp of ...@@ -673,15 +717,18 @@ instantiate tdecl texp = case texp of
maybeReplaceField (CField n'' v'' e) = maybeReplaceField (CField n'' v'' e) =
CField n'' v'' $ maybeReplaceVar varMap e CField n'' v'' $ maybeReplaceVar varMap e
--- Recursively transforms all module names of all constructor references in the
--- type expression into the module names of version A. --- Recursively transforms the module names of all type constructors in a
mapTypes :: ComparisonInfo -> CTypeExpr -> CTypeExpr --- type expression into new module names according to a mapping of
mapTypes info (CFuncType a b) = CFuncType (mapTypes info a) (mapTypes info b) --- module names.
mapTypes info (CTApply a b) = CTApply (mapTypes info a) (mapTypes info b) mapTypes :: [(String,String)] -> CTypeExpr -> CTypeExpr
mapTypes _ v@(CTVar _) = v mapTypes mmap (CFuncType a b) = CFuncType (mapTypes mmap a) (mapTypes mmap b)
mapTypes info (CTCons (m, n)) = case lookup m (infModMapA info) of mapTypes mmap (CTApply a b) = CTApply (mapTypes mmap a) (mapTypes mmap b)
Nothing -> CTCons (m, n) mapTypes _ v@(CTVar _) = v
Just m' -> CTCons (m', n) mapTypes mmap (CTCons (m, n)) =
case lookup m mmap of
Nothing -> CTCons (m, n)
Just m' -> CTCons (m', n)
realArity :: CFuncDecl -> Int realArity :: CFuncDecl -> Int
realArity (CFunc _ _ _ t _) = arityOfType (typeOfQualType t) realArity (CFunc _ _ _ t _) = arityOfType (typeOfQualType t)
...@@ -717,13 +764,18 @@ transCTCon2Limit (_,tcn) = ("Compare", "limit" ++ trans tcn) ...@@ -717,13 +764,18 @@ transCTCon2Limit (_,tcn) = ("Compare", "limit" ++ trans tcn)
| "(," `isPrefixOf` n = "Tuple" ++ show (length n - 1) | "(," `isPrefixOf` n = "Tuple" ++ show (length n - 1)
| otherwise = n | otherwise = n
--- Qualify a name by `Test.EasyCheck` module:
easyCheckMod :: String -> QName
easyCheckMod n = ("Test.EasyCheck", n)
--- Generates a function type for the test function by replacing the result --- Generates a function type for the test function by replacing the result
--- type with `Test.EasyCheck.Prop`. Also instantiates polymorphic types to --- type with `Test.EasyCheck.Prop`. Also instantiates polymorphic types to
--- Bool. --- Bool.
genTestFuncType :: CFuncDecl -> CTypeExpr genTestFuncType :: CFuncDecl -> CTypeExpr
genTestFuncType f = replaceResultType t (baseType ("Test.EasyCheck", "Prop")) genTestFuncType f = replaceResultType t (baseType (easyCheckMod "Prop"))
where t = instantiateBool $ typeOfQualType $ funcType f where t = instantiateBool $ typeOfQualType $ funcType f
--- Instantiates all type variables in a type expression to `Prelude.Bool`.
instantiateBool :: CTypeExpr -> CTypeExpr instantiateBool :: CTypeExpr -> CTypeExpr
instantiateBool (CTVar _) = boolType instantiateBool (CTVar _) = boolType
instantiateBool (CTCons n) = CTCons n instantiateBool (CTCons n) = CTCons n
...@@ -782,33 +834,36 @@ findFunctionsToCompare :: Config ...@@ -782,33 +834,36 @@ findFunctionsToCompare :: Config
-> Maybe [String] -> Maybe [String]
-> IO (ErrorLogger (ACYCache, [String], -> IO (ErrorLogger (ACYCache, [String],
[(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)])) [(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)]))
findFunctionsToCompare cfg repo gc dirA dirB useanalysis cmods = findFunctionsToCompare cfg repo gc dirA dirB useanalysis onlymods =
loadPackageSpec dirA |>= \pkgA -> loadPackageSpec dirA |>= \pkgA ->
loadPackageSpec dirB |>= \pkgB -> loadPackageSpec dirB |>= \pkgB ->
resolveAndCopyDependencies cfg repo gc dirA |>= \depsA -> resolveAndCopyDependencies cfg repo gc dirA |>= \depsA ->
succeedIO (maybe (intersect (exportedModules pkgA) (exportedModules pkgB)) succeedIO (let cmods = intersect (exportedModules pkgA) (exportedModules pkgB)
id in maybe cmods (intersect cmods) onlymods) |>= \mods ->
cmods) |>= \mods -> if null mods
log Debug ("Comparing modules: "++ intercalate " " mods) |> then log Info "No exported modules to compare" |>
APIDiff.compareModulesInDirs cfg repo gc dirA dirB (Just mods) |>= \diffs -> succeedIO (emptyACYCache,[],[],[])
findAllFunctions dirA dirB pkgA depsA emptyACYCache mods |>= else
\(acy, allFuncs) -> log Info ("Comparing modules: "++ intercalate " " mods) |>
log Debug ("All public functions: " ++ showFuncNames allFuncs) |> APIDiff.compareModulesInDirs cfg repo gc dirA dirB (Just mods) |>= \diffs ->
let areDiffThenFilter = thenFilter allFuncs Diffing findAllFunctions dirA dirB pkgA depsA emptyACYCache mods |>=
areHighArityThenFilter = thenFilter allFuncs HighArity \(acy, allFuncs) ->
areIOActionThenFilter = thenFilter allFuncs IOAction log Debug ("All public functions: " ++ showFuncNames allFuncs) |>
areNoCompareThenFilter = thenFilter allFuncs NoCompare let areDiffThenFilter = thenFilter allFuncs Diffing
areNonMatchingThenFilter = thenFilter allFuncs NonMatchingTypes areHighArityThenFilter = thenFilter allFuncs HighArity
haveFuncArgThenFilter = thenFilter allFuncs FuncArg areIOActionThenFilter = thenFilter allFuncs IOAction
in areNoCompareThenFilter = thenFilter allFuncs NoCompare
(emptyFilter ((liftFilter $ filterDiffingFunctions diffs) acy allFuncs) areNonMatchingThenFilter = thenFilter allFuncs NonMatchingTypes
`areDiffThenFilter` haveFuncArgThenFilter = thenFilter allFuncs FuncArg
liftFilter filterHighArity `areHighArityThenFilter` in
liftFilter filterIOAction `areIOActionThenFilter` (emptyFilter ((liftFilter $ filterDiffingFunctions diffs) acy allFuncs)
filterNoCompare dirA dirB depsA `areNoCompareThenFilter` `areDiffThenFilter`
filterNonMatchingTypes dirA dirB depsA `areNonMatchingThenFilter` liftFilter filterHighArity `areHighArityThenFilter`
filterFuncArg dirA dirB depsA `haveFuncArgThenFilter` liftFilter filterIOAction `areIOActionThenFilter`
liftFilter id ) |>= terminationFilter pkgA dirA depsA useanalysis filterNoCompare dirA dirB depsA `areNoCompareThenFilter`
filterNonMatchingTypes dirA dirB depsA `areNonMatchingThenFilter`
filterFuncArg dirA dirB depsA `haveFuncArgThenFilter`
liftFilter id ) |>= terminationFilter pkgA dirA depsA useanalysis
--- Filters out functions which are possibly non-terminating and --- Filters out functions which are possibly non-terminating and
--- non-productive, and mark productive functions so that they are --- non-productive, and mark productive functions so that they are
...@@ -1208,11 +1263,11 @@ preparePackages :: Config ...@@ -1208,11 +1263,11 @@ preparePackages :: Config
-> Version -> Version
-> IO (ErrorLogger ComparisonInfo) -> IO (ErrorLogger ComparisonInfo)
preparePackages cfg repo gc nameA verA nameB verB = preparePackages cfg repo gc nameA verA nameB verB =
GC.tryFindPackage gc nameA verA |>= GC.tryFindPackage gc nameA verA |>= \pkgA ->
\pkgA -> findPackageDir cfg pkgA |>= findPackageDir cfg pkgA |>= \dirA ->
\dirA -> GC.tryFindPackage gc nameB verB |>= GC.tryFindPackage gc nameB verB |>= \pkgB ->
\pkgB -> findPackageDir cfg pkgB |>= findPackageDir cfg pkgB |>= \dirB ->
\dirB -> preparePackageDirs cfg repo gc dirA dirB preparePackageDirs cfg repo gc dirA dirB
--- Prepares two package, one from a directory and one from the global package --- Prepares two package, one from a directory and one from the global package
--- cache. Copies them to a temporary directory and builds renamed versions of --- cache. Copies them to a temporary directory and builds renamed versions of
...@@ -1231,9 +1286,10 @@ preparePackageAndDir :: Config ...@@ -1231,9 +1286,10 @@ preparePackageAndDir :: Config
-> String -> String