------------------------------------------------------------------------------- --- This module contains functions that compare the behavior of two versions of --- 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 ( ComparisonInfo (..) , getBaseTemp , genCurryCheckProgram , diffBehavior , preparePackageDirs , preparePackageAndDir , preparePackages , findFunctionsToCompare ) where import Control.Monad import Data.Char ( isAlphaNum ) import Data.List ( intercalate, intersect, nub, splitOn, isPrefixOf , isInfixOf, find, delete, (\\), nubBy ) import Data.Maybe ( isJust, fromJust, fromMaybe, listToMaybe ) import System.Environment ( getEnv, setEnv, unsetEnv ) import AbstractCurry.Build import AbstractCurry.Pretty ( defaultOptions, ppCTypeExpr, showCProg ) import AbstractCurry.Select ( publicFuncNames, funcName, functions, funcArity , funcType, argTypes, typeName, types, tconsOfType , tconsArgsOfType, resultType, isIOType , typeOfQualType ) import AbstractCurry.Transform (updCFuncDecl) import AbstractCurry.Types ( CurryProg (..), CFuncDecl (..), CVisibility (..) , CTypeExpr (..), CPattern (..), CExpr (..) , CTypeDecl (..), CConsDecl (..), CFieldDecl (..) , CVarIName, QName) import Analysis.Types ( Analysis ) import Analysis.ProgInfo ( ProgInfo, emptyProgInfo, combineProgInfo , lookupProgInfo) import Analysis.Termination ( productivityAnalysis, Productivity(..) ) import Analysis.TypeUsage ( typesInValuesAnalysis ) import CASS.Server ( analyzeGeneric ) import RW.Base ( ReadWrite ) import System.CurryPath ( lookupModuleSource ) import System.Directory ( createDirectory, doesDirectoryExist , getTemporaryDirectory ) import System.FilePath ( (), joinPath ) import System.Path ( getFileInPath ) import Text.Pretty ( pPrint, text, indent, vcat, (<+>), (<$$>) ) import CPM.AbstractCurry ( readAbstractCurryFromDeps, loadPathForPackage ) import CPM.Config ( Config (curryExec) ) import CPM.Diff.API as APIDiff import CPM.Diff.CurryComments (readComments, getFuncComment) import CPM.Diff.Rename (prefixPackageAndDeps) import CPM.ErrorLogger import CPM.FileUtil ( copyDirectory, recreateDirectory, inDirectory , joinSearchPath, tempDir ) import CPM.Package ( Package, Version, name, version, showVersion, packageId , exportedModules, loadPackageSpec) import CPM.PackageCache.Global as GC import CPM.PackageCopy (resolveAndCopyDependencies) import CPM.Repository (Repository) -- What this module does (and how) -- =============================== -- -- This module compares two package versions using CurryCheck/EasyCheck. Each -- function that can be tested (the criteria for what makes a function testable -- are listed below), is compared using a EasyCheck property test equating both -- versions of the function. A function is considered testable, if -- -- - it is present in both versions of the module AND -- - its type is unchanged between both versions of the module AND -- - it is public AND -- - its argument types are either all types from the Curry standard library or -- they are the same in both versions of the module (including types in -- package dependencies) AND -- - the function is not marked with a do-not-checked pragma -- -- To test a function, we have to generate a new Curry program containing a test -- that calls both versions of the function (from the old and from the new -- version of the package) and compares the results. Since we have to use both -- versions of the package from within the same Curry program, we have to rename -- their modules to be able to import both into the same program. Renaming the -- modules also means renaming all references to the modules. And since the -- package's dependencies can also change between different versions, we have to -- rename all modules in all transitive dependencies as well. When renaming the -- modules, we simply prefix them with the version of the original package (i.e. -- the transitive dependencies get the same prefix as the original package). If -- we have package versions 1.0.0 and 1.1.0 and our module is called -- `Test.Functions`, then we will rename the from version 1.0.0 to -- `V_1_0_0_Test.Functions` and the one from version 1.1.0 to -- `V_1_1_0_Test.Functions`. -- -- We can now import both module versions and call functions from both versions -- in the same Curry program. We still have a problem with property tests that -- are parameterized over a data type present in one of the packages or one of -- its dependencies: -- -- ``` -- test_sayHello :: SayHello.MyType -> Test.Prop.Prop -- test_sayHello x0 = V_1_0_0_SayHello.sayHello x0 <~> V_1_1_0_SayHello.sayHello x0 -- ``` -- -- In this scenario, the parameter type cannot remain `SayHello.MyType`, since -- we renamed both versions of the module and they each have their own version -- of the type, `V_1_0_0_SayHello.MyType` and `V_1_1_0_SayHello.MyType`. If we -- choose one of the renamed types, we cannot give it to the function from the -- other version of the module as-is. So we generate translator functions that -- can translate one version of the data type into the other, using -- `genTranslatorFunction`. -- -- The comments in this module refer to version A and version B of the module -- and/or package. Which version is which (e.g. whether A is the smaller -- version) is irrelevant. --- Contains information from the package preparation (moving to temp directory --- and renaming). data ComparisonInfo = ComparisonInfo { infPackageA :: Package --- A version of package , infPackageB :: Package --- B version of package , infDirA :: String --- Directory where renamed A version is stored , infDirB :: String --- Directory where renamed B version is stored , infSourceDirA :: String --- Directory where original A version is stored , infSourceDirB :: String --- Directory where original B version is stored , infPrefixA :: String --- Prefix for modules in A version , infPrefixB :: String --- Prefix for modules in B version , infModMapA :: [(String, String)] --- Map from old to new module names, ver A , infModMapB :: [(String, String)] --- Map from old to new module names, ver B } --- Create temporary directory for the behavior diff. createBaseTemp :: IO String createBaseTemp = do tmpDir <- getTemporaryDirectory let tmp = tmpDir "CPM" "bdiff" recreateDirectory tmp return tmp --- Get temporary directory for the behavior diff. getBaseTemp :: IO String getBaseTemp = do tmpDir <- getTemporaryDirectory return $ tmpDir "CPM" "bdiff" --- This message is printed before CurryCheck is executed. infoText :: String infoText = unlines [ "Running behavior diff where the raw output of CurryCheck is shown." , "The test operations are named after the operations they compare." , "If a test fails, their implementations semantically differ." ] --- Compare the behavior of two package versions using CurryCheck. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @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 mods - a list of modules to compare diffBehavior :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> Bool -> Bool -> Maybe [String] -> ErrorLogger () diffBehavior cfg repo gc info groundequiv useanalysis cmods = do baseTmp <- liftIOEL getBaseTemp (acyCache, loadpath, funcs, removed) <- findFunctionsToCompare cfg repo gc (infSourceDirA info) (infSourceDirB info) useanalysis cmods let filteredFuncs = maybe funcs (\mods -> filter ((`elem` mods) . fst . funcName . snd) funcs) cmods filteredNames = map snd filteredFuncs logDebug ("Filtered operations to be checked: " ++ showFuncNames filteredNames) case funcs of [] -> liftIOEL (printRemoved removed >> return ()) _ -> do liftIOEL $ do putStrLn infoText printRemoved removed putStrLn $ "Comparing operations " ++ showFuncNames filteredNames ++ "\n" genCurryCheckProgram cfg repo gc filteredFuncs info groundequiv acyCache loadpath callCurryCheck cfg info baseTmp where printRemoved removed = if null removed then return () else putStrLn (renderRemoved removed) >> putStrLn "" --- Renders the list of functions that were excluded from the comparison along --- with reasons for their exclusion. renderRemoved :: [(CFuncDecl, FilterReason)] -> String renderRemoved rs = pPrint $ text "The following operations are not compared:" <$$> vcat (map renderReason rs) where renderReason (f, r) = indent 4 $ (text $ showQName (funcName f)) <+> text "-" <+> reasonText r reasonText NoReason = text "Unknown reason" reasonText Diffing = text "Different function types or function missing" reasonText NonMatchingTypes = text "Some types inside the function type differ" reasonText HighArity = text "Arity too high" reasonText IOAction = text "IO action" reasonText NoCompare = text "Marked NOCOMPARE" reasonText FuncArg = text "Takes functions as arguments" reasonText NonTerm = text "Possibly non-terminating" --- Runs CurryCheck on the generated program. callCurryCheck :: Config -> ComparisonInfo -> String -> ErrorLogger () callCurryCheck _ info baseTmp = do oldPath <- liftIOEL $ getEnv "CURRYPATH" let currypath = infDirA info ++ ":" ++ infDirB info mbccfile <- liftIOEL $ getFileInPath "curry-check" ecode <- maybe (do logInfo "CurryCheck not found, no comparison performed" return 0) (\cc -> do liftIOEL $ setEnv "CURRYPATH" currypath logDebug $ "Run `curry-check Compare' in `" ++ baseTmp ++ "' with" logDebug $ "CURRYPATH=" ++ currypath ec <- inDirectoryEL baseTmp $ showExecCmd (cc ++ " Compare") liftIOEL $ setEnv "CURRYPATH" oldPath logDebug "CurryCheck finished" return ec) mbccfile if ecode==0 then return () else logError "CurryCheck detected behavior error!" --- Generates a program containing CurryCheck tests that will compare the --- behavior of the given functions. The program will be written to the --- `Compare.curry` file in the behavior diff temp directory. genCurryCheckProgram :: Config -> Repository -> GC.GlobalCache -> [(Bool,CFuncDecl)] -> ComparisonInfo -> Bool -> ACYCache -> [String] -> ErrorLogger () genCurryCheckProgram cfg repo gc prodfuncs info groundequiv acyCache loadpath = do baseTmp <- liftIOEL $ getBaseTemp let translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info (_, transMap) <- foldM translatorGenerator (acyCache, emptyTrans) translateTypes let (limittypes,testFunctions) = unzip (map (genTestFunction info groundequiv transMap) prodfuncs) let transFunctions = transFuncs transMap let limittconss = nub (concatMap tconsOfType (concat limittypes)) let limittcmods = nub (map fst limittconss) -- get the declarations of all types which require limit functions: (_, limittdecls) <- foldM addLimitType (acyCache,[]) limittconss typeinfos <- analyzeModules "recursive type" typesInValuesAnalysis loadpath limittcmods let limitFunctions = concatMap (genLimitFunction typeinfos) limittdecls prog = simpleCurryProg "Compare" imports [] (concat testFunctions ++ transFunctions ++ (if groundequiv then limitFunctions else [])) [] let prodops = map snd (filter fst prodfuncs) liftIOEL $ unless (null prodops) $ putStrLn $ "Productive operations (currently not fully supported for all types):\n" ++ showFuncNames prodops ++ "\n" liftIOEL $ writeFile (baseTmp "Compare.curry") (progcmts ++ "\n" ++ showCProg prog ++ "\n") return () where addLimitType (acy,tdecls) qn = findTypeInModules cfg repo gc info acy qn >>= \ (acy',tdecl) -> return (acy', tdecl:tdecls) progcmts = unlines $ map ("-- "++) [ "This file contains properties to compare packages" , packageId (infPackageA info) ++ " and " ++ packageId (infPackageB info) ++ "." , "" , "It should be processed by 'curry-check Compare' with setting" , "export CURRYPATH=" ++ infDirA info ++ ":" ++ infDirB info ] allReferencedTypes = nub ((concat $ map (argTypes . typeOfQualType . funcType . snd) prodfuncs) ++ map (resultType . typeOfQualType . funcType . snd) prodfuncs) translateTypes = filter (needToTranslatePart info) allReferencedTypes mods = map (fst . funcName . snd) prodfuncs modsA = map (\mod -> (infPrefixA info) ++ "_" ++ mod) mods modsB = map (\mod -> (infPrefixB info) ++ "_" ++ mod) mods imports = modsA ++ modsB ++ ["Test.Prop"] --- Generates functions to limit the result depth of values of --- the given data type. genLimitFunction :: ProgInfo [QName] -> CTypeDecl -> [CFuncDecl] genLimitFunction typeinfos tdecl = case tdecl of CType tc _ tvs consdecls _ -> [stCmtFunc ("Limit operation for type " ++ tcname) (transCTCon2Limit tc) (length tvs + 2) Private (foldr (~>) (limitFunType (applyTC tc (map CTVar tvs))) (map (limitFunType . CTVar) tvs)) (cdecls2rules tc tvs consdecls)] _ -> error $ "Cannot generate limit function for type " ++ tcname where tcname = showQName (typeName tdecl) limitFunType texp = baseType ("Nat","Nat") ~> texp ~> texp var2limitfun (i,ti) = (i,"lf"++ti) cdecls2rules tc tvs cdecls = if null cdecls then [simpleRule [CPVar (0,"_"), CPVar (1,"x")] (CVar (1,"x"))] else concatMap (cdecl2rules tvs (nullaryConsOf cdecls)) cdecls where nullaryConsOf [] = error $ "Cannot generate limit operation for types " ++ "without nullary constructors: " ++ showQName tc nullaryConsOf (CCons qc _ [] : _ ) = qc nullaryConsOf (CCons _ _ (_:_) : cs) = nullaryConsOf cs nullaryConsOf (CRecord _ _ _ : cs) = nullaryConsOf cs cdecl2rules tvs tnull (CCons qc _ texps) = let lfunargs = map (CPVar . var2limitfun) tvs argvars = map (\i -> (i,"x"++show i)) [0 .. length texps - 1] isRecursive t = t `elem` fromMaybe [] (lookupProgInfo t typeinfos) isRecursiveCons = any isRecursive (concatMap tconsOfType texps) in (if isRecursiveCons then [simpleRule (lfunargs ++ [CPComb ("Nat","Z") [], CPComb qc (map CPVar argvars)]) (applyF tnull [])] else []) ++ [simpleRule (lfunargs ++ [if isRecursiveCons then CPComb ("Nat","S") [CPVar (0,"n")] else CPVar (0,"n"), CPComb qc (map CPVar argvars)]) (applyF qc (map (\ (te,v) -> applyE (type2LimOp te) [CVar (0,"n"), CVar v]) (zip texps argvars)))] cdecl2rules _ _ (CRecord qc _ _) = error $ "Cannot generate limit operation for record field " ++ showQName qc type2LimOp texp = case texp of CTVar tv -> CVar (var2limitfun tv) CFuncType _ _ -> 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)) (tconsArgsOfType texp) --- 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 --- the function in order to generate "limit" functions for this type. genTestFunction :: ComparisonInfo -> Bool -> TransMap -> (Bool, CFuncDecl) -> ([CTypeExpr], [CFuncDecl]) genTestFunction info groundequiv tm (isprod,f) = (if isprod && groundequiv then [newResultTypeA] else [], if groundequiv then [stCmtFunc ("Check ground equivalence of operation " ++ fmod ++ "." ++ fname ++ if isprod then " up to a depth limit" else "") (modName, testName ++ "_GroundEquiv") (realArity f) Private newType [if isprod then let limitvar = (100,"limit") in simpleRule (if isprod then CPVar limitvar : vars else vars) (applyF (easyCheckMod "<~>") [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 (fmod,fname) = funcName f modName = "Compare" both fun (a, b) = (fun a, fun b) testName = "test_" ++ combineTuple (both (replace' '.' '_') $ (fmod, encodeCurryId fname)) "_" testName1 = (modName, testName++"_1") testName2 = (modName, testName++"_2") vars = pVars (realArity f) modA = infPrefixA info ++ "_" ++ fmod modB = infPrefixB info ++ "_" ++ fmod instantiatedFunc = instantiateBool $ typeOfQualType $ funcType f newResultTypeA = mapTypes (infModMapA info) (instantiateBool (resultType (typeOfQualType (funcType 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 else ftype returnTransform = case findTrans tm (resultType $ instantiatedFunc) of Nothing -> id Just tr -> \t -> applyF (modName, tr) [t] -- 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 -- the tested function using the translator functions from the TransMap. As we -- already have translator functions from data type version A to B, we will -- translate the result of the A function using these functions. The -- comparison of function results will thus be done on the B version of the -- types, while the parameter generation will be done on the A version. callA = returnTransform $ applyF (modA, fname) $ map (\(CPVar v) -> CVar v) vars callB = applyF (modB, fname) $ map transformedVar $ zip (argTypes $ instantiatedFunc) vars transformedVar (texp,exp) = case (texp,exp) of (CTVar _, CPVar v) -> CVar v (CFuncType _ _, CPVar v) -> CVar v (_, CPVar v) -> maybe (CVar v) (\_ -> case findTrans tm texp of Just n -> applyF (modName, n) [CVar v] Nothing -> CVar v) (tconsArgsOfType texp) _ -> error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach" -- encode a Curry identifier into an alphanum form: encodeCurryId :: String -> String encodeCurryId [] = [] encodeCurryId (c:cs) | isAlphaNum c || c == '_' = c : encodeCurryId cs | otherwise = let oc = ord c in int2hex (oc `div` 16) : int2hex (oc `mod` 16) : encodeCurryId cs where int2hex i = if i<10 then chr (ord '0' + i) else chr (ord 'A' + i - 10) --- Checks if any part of the given type needs to be translated using a --- translator function. needToTranslatePart :: ComparisonInfo -> CTypeExpr -> Bool needToTranslatePart _ (CTVar _) = False needToTranslatePart info (CFuncType e1 e2) = needToTranslatePart info e1 || needToTranslatePart info e2 needToTranslatePart info (CTApply e1 e2) = needToTranslatePart info e1 || needToTranslatePart info e2 needToTranslatePart info (CTCons n) = isMappedType info n --- Checks if the module of the given type is one of the mapped modules, i.e. --- one that is present in two versions. isMappedType :: ComparisonInfo -> (String, String) -> Bool isMappedType info (mod, _) = isJust $ lookup mod (infModMapA info) --- The TransMap contains a map of type expressions to translator function --- names, as well as the next translator function number and a list of the --- translator functions themselves. data TransMap = TransMap [(CTypeExpr, String)] Int [CFuncDecl] --- An empty TransMap. emptyTrans :: TransMap emptyTrans = TransMap [] 0 [] --- Adds an entry to the TransMap. Note that this does not add the --- function itself. Use `addFunc` to add the function. addEntry :: TransMap -> CTypeExpr -> (TransMap, String) addEntry (TransMap m n fs) e = (TransMap ((e, "tt_" ++ show n) : m) (n + 1) fs, "tt_" ++ show n) --- Adds a translator function to the list of functions in the TransMap. addFunc :: TransMap -> CFuncDecl -> TransMap addFunc (TransMap m n fs) f = TransMap m n (f:fs) --- Finds the name of the translator function for a type expression, if it --- exists. findTrans :: TransMap -> CTypeExpr -> Maybe String findTrans (TransMap m _ _) e = lookup e m --- Gets all translator functions from a TransMap. transFuncs :: TransMap -> [CFuncDecl] transFuncs (TransMap _ _ fs) = fs --- Get type declarations for some types that are namespaced to the Prelude --- module, but whose type declarations are not actually contained in the --- Prelude module. predefinedType :: (String, String) -> Maybe CTypeDecl predefinedType x = case x of ("Prelude", "[]") -> Just $ CType ("Prelude", "[]") Public [(0, "a")] [ simpleCCons ("Prelude", "[]") Public [] , simpleCCons ("Prelude", ":") Public [CTVar (0, "a"), listType (CTVar (0, "a"))]] [] ("Prelude", "(,)") -> Just $ CType ("Prelude", "(,)") Public [(0, "a"), (1, "b")] [ simpleCCons ("Prelude", "(,)") Public [CTVar (0, "a"), CTVar (1, "b")]] [] ("Prelude", "(,,)") -> Just $ CType ("Prelude", "(,,)") Public [(0, "a"), (1, "b"), (2, "c")] [ simpleCCons ("Prelude", "(,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c")]] [] ("Prelude", "(,,,)") -> Just $ CType ("Prelude", "(,,,)") Public [(0, "a"), (1, "b"), (2, "c"), (3, "d")] [ simpleCCons ("Prelude", "(,,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c"), CTVar (3, "d")]] [] _ -> Nothing --- The ACYCache caches the AbstractCurry representations of Curry modules, --- specific to the directory it is stored in (to support multiple versions of a --- module). data ACYCache = ACYCache [(String, [(String, CurryProg)])] --- An empty ACYCache. emptyACYCache :: ACYCache emptyACYCache = ACYCache [] --- Finds a module inside an ACYCache, regardless of its directory. findModule :: String -> ACYCache -> Maybe CurryProg findModule mod (ACYCache ps) = case lookup mod ps of Nothing -> Nothing Just ms -> listToMaybe $ map snd ms --- Finds a module inside the ACYCache that was read from a specific directory. findModuleDir :: String -> String -> ACYCache -> Maybe CurryProg findModuleDir dir mod (ACYCache ps) = case lookup mod ps of Nothing -> Nothing Just ms -> lookup dir ms --- Adds a module to the ACYCache without a directory. addModule :: String -> CurryProg -> ACYCache -> ACYCache addModule mod p (ACYCache ps) = case lookup mod ps of Just _ -> ACYCache ps Nothing -> ACYCache $ (mod, [("", p)]):ps --- Adds a module to the ACYCache with a directory. addModuleDir :: String -> String -> CurryProg -> ACYCache -> ACYCache addModuleDir dir mod p (ACYCache ps) = case lookup mod ps of Just ms -> case lookup dir ms of Just _ -> ACYCache ps Nothing -> ACYCache $ (mod, (dir, p):ms):(delete (mod, ms) ps) Nothing -> ACYCache $ (mod, [(dir, p)]):ps --- Generate a translator function for a type expression. Expects a CTCons. --- --- @param cfg current CPM configuration --- @param repo package repository --- @param gc the global package cache --- @param info information about the current comparison --- @param tm the map of translator functions --- @param e the type expression to generate a translator for genTranslatorFunction :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> ACYCache -> TransMap -> CTypeExpr -> ErrorLogger (ACYCache, TransMap) 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 (error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++ "cannot generate type translation function for type:\n" ++ pPrint (ppCTypeExpr defaultOptions texp)) fst (tconsArgsOfType texp) in -- Don't generate another translator if there already is one for the current -- type. if isJust $ findTrans tm t' then return (acy, tm) else findTypeInModules cfg repo gc info acy (mod,n) >>= -- We want to work on the constructors with all type variables instantiated -- with the types from the type that we're supposed to build a translator for. \(acy', typeDecl) -> (return $ instantiate typeDecl t') >>= -- Add the entry at this point to make sure that it's available when we -- generate the other translators and if we need to call it recursively later -- on. \instTypeDecl -> (return $ addEntry tm t') >>= \(tm', name) -> foldM (uncurry $ genTranslatorFunction cfg repo gc info) (acy', tm') (transExprs instTypeDecl) >>= \(acy'', tm'') -> let aType = prefixMappedTypes (infPrefixA info) t' bType = prefixMappedTypes (infPrefixB info) t' fType = CFuncType aType bType fName = ("Compare", name) mapIfNeeded modMap m = if isMappedType info (m, "") then fromJust $ lookup m modMap else m mapIfNeededA = mapIfNeeded (infModMapA info) mapIfNeededB = mapIfNeeded (infModMapB info) transformer (i,te) = case te of CTVar _ -> CVar (i, "x" ++ show i) CFuncType _ _ -> CVar (i, "x" ++ show i) _ -> case findTrans tm'' te of Nothing -> CVar (i, "x" ++ show i) Just tn -> applyF ("Compare", tn) [CVar (i, "x" ++ show i)] ruleForCons (CCons (m, cn) _ es) = simpleRule [pattern] call where pattern = CPComb (mapIfNeededA m, cn) (pVars (length es)) -- Apply constructor from B, calling translator functions if neccessary. call = applyF (mapIfNeededB m, cn) $ map transformer $ zip (take (length es) [0..]) es ruleForCons (CRecord (m, cn) _ fs) = simpleRule [pattern] call where pattern = CPComb (mapIfNeededA m, cn) (pVars (length fs)) call = applyF (mapIfNeededB m, cn) $ map transformer $ zip (take (length fs) [0..]) (map (\(CField _ _ es) -> es) fs) synRule e = simpleRule [CPVar (0, "x0")] call where call = transformer (0, e) in case instTypeDecl of CType _ _ _ cs _ -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType (map ruleForCons cs))) CTypeSyn _ _ _ e -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType [synRule e])) CNewType _ _ _ c _ -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType [ruleForCons c])) where -- Since our test functions always use polymorphic types instantiated to Bool, -- we generate our translator functions for Bool-instantiated types as well. t' = instantiateBool texp -- Finds all type expressions in the instantiated constructors that contain -- types that need to be translated. transExprs cs = filter (needToTranslatePart info) $ nub $ extractExprs cs extractExprs (CType _ _ _ es _) = concat $ map extractExprsCons es extractExprs (CTypeSyn _ _ _ e) = [e] extractExprs (CNewType _ _ _ c _) = extractExprsCons c extractExprsCons (CCons _ _ es) = es extractExprsCons (CRecord _ _ fs) = map (\(CField _ _ es) -> es) fs -- Recursively prefixes those types which are present in two versions. prefixMappedTypes pre (CTCons (mod', n')) = if isMappedType info (mod', n') then CTCons (pre ++ "_" ++ mod', n') else CTCons (mod', n') prefixMappedTypes _ (CTVar v) = CTVar v prefixMappedTypes pre (CFuncType e1 e2) = CFuncType (prefixMappedTypes pre e1) (prefixMappedTypes pre e2) prefixMappedTypes pre (CTApply e1 e2) = CTApply (prefixMappedTypes pre e1) (prefixMappedTypes pre e2) -- Finds the type declaration for a given qualified type constructor. -- If the module is not in the ACYCache, it is read and added to the cache. findTypeInModules :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> ACYCache -> QName -> ErrorLogger (ACYCache, CTypeDecl) findTypeInModules cfg repo gc info acy (mod,n) = case predefinedType (mod, n) of Just ty -> return (acy, ty) Nothing -> (case findModule mod acy of Just p -> return $ p Nothing -> resolveAndCopyDependencies cfg repo gc (infSourceDirA info) >>= \deps -> readAbstractCurryFromDeps (infSourceDirA info) deps mod >>= return) >>= \prog -> case filter ((== n) . snd . typeName) (types prog) of [] -> fail $ "No type defined '" ++ n ++ "' in module '" ++ mod ++ "'" (x:_) -> return (addModule mod prog acy, x) --- Replaces type variables with their expression in the map if there is one, --- leaves them alone otherwise. maybeReplaceVar :: [(CVarIName, CTypeExpr)] -> CTypeExpr -> CTypeExpr maybeReplaceVar vm (CTVar v) = case lookup v vm of Nothing -> CTVar v Just e' -> e' maybeReplaceVar _ (CTCons n) = CTCons n maybeReplaceVar vm (CFuncType e1 e2) = CFuncType (maybeReplaceVar vm e1) (maybeReplaceVar vm e2) maybeReplaceVar vm (CTApply e1 e2) = CTApply (maybeReplaceVar vm e1) (maybeReplaceVar vm e2) --- Instantiates all constructors of a type declaration with the types from a --- constructor type expression. Type variables that are not used in the --- constructor referenced by the type expression remain as they are. instantiate :: CTypeDecl -> CTypeExpr -> CTypeDecl instantiate tdecl texp = case texp of CTVar _ -> error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTVar" CFuncType _ _ -> error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType" _ -> maybe (error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTApply") (\ (_,texps) -> instantiate' tdecl texps) (tconsArgsOfType texp) where instantiate' (CType n v vs cs d) es = CType n v vs (map cons cs) d where varMap = zip vs es cons (CCons n' v' es') = CCons n' v' $ map (maybeReplaceVar varMap) es' cons (CRecord n' v' fs') = CRecord n' v' $ map maybeReplaceField fs' maybeReplaceField (CField n'' v'' e) = CField n'' v'' $ maybeReplaceVar varMap e instantiate' (CTypeSyn n v vs e) es = CTypeSyn n v vs $ maybeReplaceVar varMap e where varMap = zip vs es instantiate' (CNewType n v vs c d) es = CNewType n v vs (cons c) d where varMap = zip vs es cons (CCons n' v' es') = CCons n' v' $ map (maybeReplaceVar varMap) es' cons (CRecord n' v' fs') = CRecord n' v' $ map maybeReplaceField fs' maybeReplaceField (CField n'' v'' e) = CField n'' v'' $ maybeReplaceVar varMap e --- Recursively transforms the module names of all type constructors in a --- type expression into new module names according to a mapping of --- module names. mapTypes :: [(String,String)] -> CTypeExpr -> CTypeExpr mapTypes mmap (CFuncType a b) = CFuncType (mapTypes mmap a) (mapTypes mmap b) mapTypes mmap (CTApply a b) = CTApply (mapTypes mmap a) (mapTypes mmap b) mapTypes _ v@(CTVar _) = v mapTypes mmap (CTCons (m, n)) = case lookup m mmap of Nothing -> CTCons (m, n) Just m' -> CTCons (m', n) realArity :: CFuncDecl -> Int realArity (CFunc _ _ _ t _) = arityOfType (typeOfQualType t) realArity (CmtFunc _ _ _ _ t _) = arityOfType (typeOfQualType t) arityOfType :: CTypeExpr -> Int arityOfType (CFuncType _ b) = 1 + arityOfType b arityOfType (CTVar _) = 0 arityOfType (CTCons _) = 0 arityOfType (CTApply _ _) = 0 -- Wrap an expression of a given type with a call to a corresponding -- depth-limit function: type2LimitFunc :: CTypeExpr -> CExpr type2LimitFunc texp = case texp of CTVar _ -> error "type2LimitFunc: cannot generate limit operation for type variable" CFuncType _ _ -> error "type2LimitFunc: cannot generate limit operation for function type" _ -> maybe (error "type2LimitFunc: cannot generate limit operation for type application") (\ (tc,ts) -> applyF (transCTCon2Limit tc) (map type2LimitFunc ts)) (tconsArgsOfType texp) -- Translate a type constructor name to the name of the corresponding limit -- operation: transCTCon2Limit :: QName -> QName transCTCon2Limit (_,tcn) = ("Compare", "limit" ++ trans tcn) where trans n | n=="[]" = "List" | n=="()" = "Unit" | "(," `isPrefixOf` n = "Tuple" ++ show (length n - 1) | otherwise = n --- Qualify a name by `Test.Prop` module: easyCheckMod :: String -> QName easyCheckMod n = ("Test.Prop", n) --- Generates a function type for the test function by replacing the result --- type with `Test.Prop.Prop`. Also instantiates polymorphic types to --- Bool. genTestFuncType :: CFuncDecl -> CTypeExpr genTestFuncType f = replaceResultType t (baseType (easyCheckMod "Prop")) where t = instantiateBool $ typeOfQualType $ funcType f --- Instantiates all type variables in a type expression to `Prelude.Bool`. instantiateBool :: CTypeExpr -> CTypeExpr instantiateBool (CTVar _) = boolType instantiateBool (CTCons n) = CTCons n instantiateBool (CTApply a b) = CTApply (instantiateBool a) (instantiateBool b) instantiateBool (CFuncType a b) = CFuncType (instantiateBool a) (instantiateBool b) --- Replaces the result type of a function type. replaceResultType :: CTypeExpr -> CTypeExpr -> CTypeExpr replaceResultType (CFuncType a (CTVar _)) z = CFuncType a z replaceResultType (CFuncType a (CTCons _)) z = CFuncType a z replaceResultType (CFuncType a (CTApply _ _)) z = CFuncType a z replaceResultType (CFuncType a b@(CFuncType _ _)) z = CFuncType a (replaceResultType b z) replaceResultType (CTVar _) z = z replaceResultType (CTCons _) z = z replaceResultType (CTApply _ _) z = z combineTuple :: (String, String) -> String -> String combineTuple (a, b) s = a ++ s ++ b showQName :: QName -> String showQName qn = combineTuple qn "." showFuncNames :: [CFuncDecl] -> String showFuncNames = intercalate ", " . map (showQName . funcName) replace' :: Eq a => a -> a -> [a] -> [a] replace' _ _ [] = [] replace' o n (x:xs) | x == o = n : replace' o n xs | otherwise = x : replace' o n xs ------------------------------------------------------------------------------ --- Finds a list of functions that can be compared. At the moment, this uses the --- functionality from `CPM.Diff.API` to compare the public interfaces of both --- module versions and find the functions that have not changed between --- versions. --- --- @param cfg the CPM configuration --- @param repo the current repository --- @param gc the global package cache --- @param dirA the directory of the A version of the package --- @param dirB the directory of the B version of the package --- @param useanalysis - use program analysis to filter non-term. operations? --- @param mods - the modules to compare (if Nothing, compare exported modules) --- @return a tuple consisting of an ACYCache, a list of functions to --- be compared (with a flag which is true if they are productive, --- might be non-terminating but can be compared level-wise), --- and a list of non-comparable functions with a reason findFunctionsToCompare :: Config -> Repository -> GC.GlobalCache -> String -> String -> Bool -> Maybe [String] -> ErrorLogger (ACYCache, [String], [(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)]) findFunctionsToCompare cfg repo gc dirA dirB useanalysis onlymods = do pkgA <- loadPackageSpec dirA pkgB <- loadPackageSpec dirB depsA <- resolveAndCopyDependencies cfg repo gc dirA let cmods = intersect (exportedModules pkgA) (exportedModules pkgB) let mods = maybe cmods (intersect cmods) onlymods if null mods then logInfo "No exported modules to compare" >> return (emptyACYCache,[],[],[]) else do logInfo ("Comparing modules: "++ intercalate " " mods) diffs <- APIDiff.compareModulesInDirs cfg repo gc dirA dirB (Just mods) (acy, allFuncs) <- findAllFunctions dirA dirB pkgA depsA emptyACYCache mods logDebug ("All public functions: " ++ showFuncNames allFuncs) let areDiffThenFilter = thenFilter allFuncs Diffing let areHighArityThenFilter = thenFilter allFuncs HighArity let areIOActionThenFilter = thenFilter allFuncs IOAction let areNoCompareThenFilter = thenFilter allFuncs NoCompare let areNonMatchingThenFilter = thenFilter allFuncs NonMatchingTypes let haveFuncArgThenFilter = thenFilter allFuncs FuncArg (emptyFilter ((liftFilter $ filterDiffingFunctions diffs) acy allFuncs) `areDiffThenFilter` liftFilter filterHighArity `areHighArityThenFilter` liftFilter filterIOAction `areIOActionThenFilter` 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 --- non-productive, and mark productive functions so that they are --- tested not by standard equality. terminationFilter :: Package -> String -> [Package] -> Bool -> (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) -> ErrorLogger (ACYCache, [String], [(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)]) terminationFilter _ _ _ False (a,fs,rm) = return (a, [], map (\f->(False,f)) fs, rm) terminationFilter pkgA dirA depsA True (acy, funcs, rm) = do let currypath = loadPathForPackage pkgA dirA depsA mods = nub (map (fst . funcName) funcs) ainfo <- analyzeModules "productivity" productivityAnalysis currypath mods -- compute functions which should be definitely compared (due to TERMINATE -- or PRODUCTIVE pragmas): modscmts <- liftIOEL $ mapM (getCompare currypath) mods let termfuns = concatMap (\md -> md ("TERMINATE" `isInfixOf`)) modscmts prodfuns = concatMap (\md -> md ("PRODUCTIVE" `isInfixOf`)) modscmts logDebug ("Functions marked with TERMINATE: " ++ showFuncNames termfuns) >> return () logDebug ("Functions marked with PRODUCTIVE: " ++ showFuncNames prodfuns) >> return () let infoOf f = fromMaybe Looping (lookupProgInfo (funcName f) ainfo) ntfuncs = filter (\f -> infoOf f == Looping && f `notElem` termfuns && f `notElem` prodfuns) funcs return (acy, currypath, map (\f -> (not (infoOf f == Terminating || f `elem` termfuns), f)) (funcs \\ ntfuncs), rm ++ map (\f -> (f,NonTerm)) ntfuncs) where --- Get functions in a module satisfying a given predicate on pragma comments getCompare currypath modname = do src <- lookupModuleSource currypath modname (_,comments) <- case src of Nothing -> error $ "Module not found: " ++ modname Just (_, file) -> readComments file return (\p -> filter (\f -> let (mn,fn) = funcName f in mn == modname && p (getFuncComment fn comments)) funcs) -- Analyze a list of modules with some static program analysis in a given -- load path. Returns the combined analysis information. -- Raises an error if something goes wrong. analyzeModules :: (Read a, Show a, ReadWrite a) => String -> Analysis a -> [String] -> [String] -> ErrorLogger (ProgInfo a) analyzeModules ananame analysis currypath mods = do logDebug ("Running " ++ ananame ++ " analysis on modules: " ++ intercalate ", " mods) logDebug ("CURRYPATH=" ++ joinSearchPath currypath) anainfos <- liftIOEL $ mapM (analyzeModule analysis currypath) mods logDebug "Analysis finished" return $ foldr combineProgInfo emptyProgInfo anainfos -- Analyze a module with some static program analysis in a given -- load path. Raises an error if something goes wrong. analyzeModule :: (Read a, Show a, ReadWrite a) => Analysis a -> [String] -> String -> IO (ProgInfo a) analyzeModule analysis currypath mod = do setEnv "CURRYPATH" (joinSearchPath currypath) aresult <- analyzeGeneric analysis mod unsetEnv "CURRYPATH" either return (\e -> do putStrLn "WARNING: error occurred during analysis:" putStrLn e putStrLn "Ignoring analysis information" return emptyProgInfo) aresult emptyFilter :: ErrorLogger (ACYCache, [CFuncDecl]) -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) emptyFilter st = st >>= \(a, fs) -> return (a, fs, []) --- Reasons why a function can be excluded from the list of functions to be --- compared. data FilterReason = NoReason | HighArity | IOAction | NoCompare | NonMatchingTypes | Diffing | FuncArg | NonTerm --- Chain filter functions and mark the ones removed by the previous filter --- with a given reason. thenFilter :: [CFuncDecl] -> FilterReason -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) -> (ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl])) -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) thenFilter allFuncs r st f = st >>= \(a, fs, rm) -> f a fs >>= \(a', fs') -> return (a', fs', rm ++ zip (findMissing rm fs) (repeat r)) where findMissing rm fs = (allFuncs \\ (map fst rm)) \\ fs --- Lifts a simple filter to a filter that executes inside the IO monad and --- takes an ACYCache. liftFilter :: ([CFuncDecl] -> [CFuncDecl]) -> (ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl])) liftFilter f = \a fs -> return (a, f fs) --- Excludes those functions which take a functional argument, either directly --- or via a nested type. filterFuncArg :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterFuncArg = filterFuncsDeep checkFunc where checkFunc (CFuncType _ _) = True checkFunc (CTVar _) = False checkFunc (CTCons _) = False checkFunc (CTApply _ _) = False --- Filters functions via a predicate on their argument types. Checks the --- predicates on nested types as well. filterFuncsDeep :: (CTypeExpr -> Bool) -> String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterFuncsDeep tpred dirA _ deps acy allFuncs = foldM checkFunc (acy, [], []) allFuncs >>= \(acy', _, fns) -> return (acy', fns) where findType n m = case predefinedType n of Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m Just ty -> Just ty checkFunc (a, c, fs) f = (foldM checkTypeExpr (a, c, False) $ argTypes $ typeOfQualType $ funcType f) >>= \(a', c', r) -> if r then return (a', c', fs) else return (a', c', f:fs) checkTypeExpr (a, c, r) t@(CFuncType e1 e2) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else checkTypeExpr (a, c, r) e1 >>= \ (a', c', r') -> checkTypeExpr (a', e1:c', r') e2 >>= \ (a'', c'', r'') -> return (a'', e2:c'', r || r' || r'') checkTypeExpr (a, c, r) t@(CTApply e1 e2) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else checkTypeExpr (a, c, r) e1 >>= \ (a', c', r') -> checkTypeExpr (a', e1:c', r') e2 >>= \ (a'', c'', r'') -> return (a'', e2:c'', r || r' || r'') checkTypeExpr (a, c, r) (CTVar _) = return (a, c, r) checkTypeExpr (a, c, r) t@(CTCons n@(mod, _)) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else return (a, c, r) >>= \(a', c', _) -> readCached dirA deps a' mod >>= \(a'', prog) -> case findType n prog of Nothing -> fail $ "Type '" ++ show n ++ "' not found." Just t' -> checkType a'' (t:c') t' >>= \(a''', c'', r'') -> return (a''', c'', r || r'') checkType a ts (CType _ _ _ cs _) = foldM checkCons (a, ts, False) cs checkType a ts (CTypeSyn _ _ _ e) = checkTypeExpr (a, ts, False) e checkType a ts (CNewType _ _ _ c _) = checkCons (a, ts, False) c checkCons (a, ts, r) (CCons _ _ es) = foldM checkTypeExpr (a, ts, r) es checkCons (a, ts, r) (CRecord _ _ fs) = let es = map (\(CField _ _ e) -> e) fs in foldM checkTypeExpr (a, ts, r) es --- Filters out functions marked with the NOCOMPARE pragma. filterNoCompare :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterNoCompare dirA dirB _ a fs = liftIOEL $ do allCommentsA <- mapM (readComments . modPath dirA) modules allCommentsB <- mapM (readComments . modPath dirB) modules let commentsA = funcsWithComments $ zip modules allCommentsA let commentsB = funcsWithComments $ zip modules allCommentsB return (a, filter (not . noCompare commentsA commentsB) fs) where modules = nub $ map (fst . funcName) fs modPath dir mod = dir "src" joinPath (splitOn "." mod) ++ ".curry" -- Zip up all functions with their respective comments. funcsWithComments cmts = zip fs (map (getFuncComment' cmts) fs) getFuncComment' cmts f = let mname = fst $ funcName f lname = snd $ funcName f in case lookup mname cmts of Nothing -> "" Just cs -> getFuncComment lname $ snd cs noCompare cmtsA cmtsB f = noCompare' cmtsA f || noCompare' cmtsB f -- Check if NOCOMPARE is mentioned in the comments noCompare' cmts f = case lookup f cmts of Nothing -> False Just c -> "NOCOMPARE" `isInfixOf` c --- Removes all functions that have more than five arguments (currently the --- maximum number of parameters that CurryCheck supports in property tests). filterHighArity :: [CFuncDecl] -> [CFuncDecl] filterHighArity = filter ((<= 5) . length . argTypes . typeOfQualType . funcType) --- Removes all IO actions since they cannot be compared as --- properties in CurryCheck. filterIOAction :: [CFuncDecl] -> [CFuncDecl] filterIOAction = filter (not . isIOType . resultType . typeOfQualType . funcType) --- Removes all functions that have a diff associated with their name from the --- given list of functions. --- --- @param fs the functions to filter --- @param ds a list of pairs of module names and diffs filterDiffingFunctions :: [(String, Differences)] -> [CFuncDecl] -> [CFuncDecl] filterDiffingFunctions diffs allFuncs = nub $ concatMap filterModule modules where modules = nub $ map (fst . funcName) allFuncs diffsForModule mod = case lookup mod diffs of Nothing -> [] Just (_, funcDiffs, _, _) -> map funcDiffName funcDiffs funcDiffName (Addition f) = funcName f funcDiffName (Removal f) = funcName f funcDiffName (Change _ f) = funcName f filterModule mod = filter (not . (`elem` (diffsForModule mod)) . funcName) (funcsForModule mod) funcsForModule mod = filter ((== mod) . fst . funcName) allFuncs --- Excludes those functions whose types do not match in both versions. Checks --- nested types. filterNonMatchingTypes :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterNonMatchingTypes dirA dirB deps acyCache allFuncs = foldM funcTypesCompatible (acyCache, [], []) allFuncs >>= \(acy, _, fns) -> return (acy, fns) where allTypes f = let ft = typeOfQualType (funcType f) in (resultType ft) : (argTypes ft) onlyCons = filter isConsType funcTypesCompatible (a, seen, fs) f = (foldM typesCompatible (a, seen, True) $ onlyCons $ allTypes f) >>= \(a', seen', c) -> if c then return (a', seen', f:fs) else return (a', seen', fs) typesCompatible (a, seen, r) t = case lookup t seen of Just b -> return (a, seen, b && r) Nothing -> typesEqual t dirA dirB deps a [] >>= \(a', r') -> return (a', ((t, r'):seen), r' && r) --- Compares the declarations of types mentioned in a type expression --- recursively. Returns False if the types are different. typesEqual :: CTypeExpr -> String -> String -> [Package] -> ACYCache -> [CTypeExpr] -> ErrorLogger (ACYCache, Bool) typesEqual texp dirA dirB deps acyCache checked = maybe (fail $ "typesEqual not called on type constructor: " ++ show texp) (return . fst) (tconsArgsOfType texp) >>= \n -> let (mod,_) = n in if texp `elem` checked then return (acyCache, True) else readCached dirA deps acyCache mod >>= \(acy',modA) -> readCached dirB deps acy' mod >>= \(acy'', modB) -> let typeA = findType n modA typeB = findType n modB in typesEqual' typeA typeB acy'' where findType n m = case predefinedType n of Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m Just ty -> Just ty typesEqual' :: Maybe CTypeDecl -> Maybe CTypeDecl -> ACYCache -> ErrorLogger (ACYCache, Bool) typesEqual' (Just (CType n1 v1 tvs1 cs1 _)) (Just (CType n2 v2 tvs2 cs2 _)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && cs1 == cs2 then foldM (\(a, r) (c1, c2) -> consEqual a c1 c2 >>= \(a', r') -> return (a', r && r')) (acy, True) (zip cs1 cs2) else return (acy, False) typesEqual' (Just (CTypeSyn n1 v1 tvs1 e1)) (Just (CTypeSyn n2 v2 tvs2 e2)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && e1 == e2 then if isConsType e1 then typesEqual e1 dirA dirB deps acy (texp:checked) else return (acy, True) else return (acy, False) typesEqual' (Just (CNewType n1 v1 tvs1 c1 _)) (Just (CNewType n2 v2 tvs2 c2 _)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && c1 == c2 then consEqual acy c1 c2 else return (acy, False) typesEqual' (Just (CType _ _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CType _ _ _ _ _)) (Just (CNewType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CNewType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CNewType _ _ _ _ _)) (Just (CType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CNewType _ _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = return (acy, False) typesEqual' Nothing (Just _) acy = return (acy, False) typesEqual' (Just _) Nothing acy = return (acy, False) typesEqual' Nothing Nothing acy = return (acy, False) consEqual :: ACYCache -> CConsDecl -> CConsDecl -> ErrorLogger (ACYCache, Bool) consEqual acy (CCons _ _ es1) (CCons _ _ es2) = foldM esEqual (acy, True) (zip es1 es2) where esEqual (a, r) (e1, e2) = if e1 == e2 then if isConsType e1 then typesEqual e1 dirA dirB deps a (texp:checked) else return (acy, r) else return (acy, False) consEqual acy (CRecord _ _ fs1) (CRecord _ _ fs2) = foldM fEqual (acy, True) (zip fs1 fs2) where fEqual (a, r) (f1@(CField _ _ e1), f2@(CField _ _ _)) = if f1 == f2 then if isConsType e1 then typesEqual e1 dirA dirB deps a (texp:checked) else return (acy, r) else return (acy, False) consEqual acy (CCons _ _ _) (CRecord _ _ _) = return (acy, False) consEqual acy (CRecord _ _ _) (CCons _ _ _) = return (acy, False) isTypePublic :: CTypeDecl -> Bool isTypePublic (CType _ v _ _ _) = v == Public isTypePublic (CTypeSyn _ v _ _) = v == Public isTypePublic (CNewType _ v _ _ _) = v == Public isConsType :: CTypeExpr -> Bool isConsType (CTCons _) = True isConsType (CTVar _) = False isConsType (CFuncType _ _) = False isConsType (CTApply t _) = isConsType t ------------------------------------------------------------------------------ --- Reads a module in AbstractCurry form. readCached :: String -> [Package] -> ACYCache -> String -> ErrorLogger (ACYCache, CurryProg) readCached dir deps acyCache mod = case findModuleDir dir mod acyCache of Just p -> return (acyCache, p) Nothing -> do prog <- readAbstractCurryFromDeps dir deps mod return (addModuleDir dir mod prog acyCache, prog) --- Reads all modules of the given package and finds all public functions --- in all of those modules. --- --- @param dirA the directory where copy A of the package is stored --- @param dirB the directory where copy B of the package is stored --- @param pkg the package --- @param deps a list of package dependencies --- @param mods the list of modules to search for public functions findAllFunctions :: String -> String -> Package -> [Package] -> ACYCache -> [String] -> ErrorLogger (ACYCache, [CFuncDecl]) findAllFunctions dirA dirB _ deps acyCache mods = logDebug ("Finding public functions of modules: " ++ intercalate "," mods) >> logDebug ("in package directories " ++ dirA ++ " and " ++ dirB) >> foldM findForMod (acyCache, []) mods >>= \(a, fs) -> return (a, nub fs) where findForMod (acy,fdecls) mod = readCached dirA deps acy mod >>= \(_, progA) -> readCached dirB deps acy mod >>= \(acy'', progB) -> let funcsA = filter isPublic $ functions progA funcsB = filter isPublic $ functions progB in return (acy'', fdecls ++ nubBy (\a b -> funcName a == funcName b) (funcsA ++ funcsB)) --- Checks whether a function is public. isPublic :: CFuncDecl -> Bool isPublic (CFunc _ _ Public _ _) = True isPublic (CFunc _ _ Private _ _) = False isPublic (CmtFunc _ _ _ Public _ _) = True isPublic (CmtFunc _ _ _ Private _ _) = False --- Prepares two packages from the global package cache in two versions for --- comparison by copying them to the temporary directory and building renamed --- versions. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param nameA the name of the first package --- @param verA the version of the first package --- @param nameB the name of the second package --- @param verB the version of the second package preparePackages :: Config -> Repository -> GC.GlobalCache -> String -> Version -> String -> Version -> ErrorLogger ComparisonInfo preparePackages cfg repo gc nameA verA nameB verB = GC.tryFindPackage gc nameA verA >>= \pkgA -> findPackageDir cfg pkgA >>= \dirA -> GC.tryFindPackage gc nameB verB >>= \pkgB -> findPackageDir cfg pkgB >>= \dirB -> preparePackageDirs cfg repo gc dirA dirB --- 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 --- the packages and all dependencies. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param dirA the directory for the first package --- @param nameB the name of the second package --- @param verB the version of the second package preparePackageAndDir :: Config -> Repository -> GC.GlobalCache -> String -> String -> Version -> ErrorLogger ComparisonInfo preparePackageAndDir cfg repo gc dirA nameB verB = GC.tryFindPackage gc nameB verB >>= \pkgB -> findPackageDir cfg pkgB >>= \dirB -> preparePackageDirs cfg repo gc dirA dirB --- Prepares two packages from two directories for comparison. Copies the --- package files to a temporary directory and creates renamed version of the --- packages and their dependencies. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param dirA the directory containing the first package --- @param dirB the directory containing the second package preparePackageDirs :: Config -> Repository -> GC.GlobalCache -> String -> String -> ErrorLogger ComparisonInfo preparePackageDirs cfg repo gc dirA dirB = do baseTmp <- liftIOEL $ createBaseTemp specA <- loadPackageSpec dirA specB <- loadPackageSpec dirB let versionPrefixA = versionPrefix specA let versionPrefixB = versionPrefix specB let copyDirA = baseTmp ("src_" ++ versionPrefixA) let copyDirB = baseTmp ("src_" ++ versionPrefixB) let destDirA = baseTmp ("dest_" ++ versionPrefixA) let destDirB = baseTmp ("dest_" ++ versionPrefixB) logDebug ("Copying " ++ packageId specA ++ " from " ++ dirA ++ " into " ++ copyDirA) logDebug ("and transforming it into " ++ destDirA) logDebug ("Copying " ++ packageId specB ++ " from " ++ dirB ++ " into " ++ copyDirB) logDebug ("and transforming it into " ++ destDirB) modMapA <- copyAndPrefixPackage cfg repo gc dirA versionPrefixA copyDirA destDirA modMapB <- copyAndPrefixPackage cfg repo gc dirB versionPrefixB copyDirB destDirB return $ ComparisonInfo { infPackageA = specA , infPackageB = specB , infDirA = destDirA , infDirB = destDirB , infSourceDirA = copyDirA , infSourceDirB = copyDirB , infPrefixA = versionPrefixA , infPrefixB = versionPrefixB , infModMapA = modMapA , infModMapB = modMapB } versionPrefix :: Package -> String versionPrefix pkg = "V_" ++ (showVersion' $ version pkg) --- Copies a package from a directory to the temporary directory and creates --- another copy of the package with all its modules and the modules of its --- dependencies prefixed with the given string. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param pkgDir the package directory to copy from --- @param prefix the prefix for the modules --- @param tmpDir the temporary directory to copy the files to --- @param srcDir the temporary directory where the source package is copied --- @param destDir the temporary directory where the prefixed copy is written copyAndPrefixPackage :: Config -> Repository -> GC.GlobalCache -> String -> String -> String -> String -> ErrorLogger [(String, String)] copyAndPrefixPackage cfg repo gc pkgDir prefix srcDir destDir = do liftIOEL $ copyDirectory pkgDir srcDir liftIOEL $ createDirectory destDir prefixPackageAndDeps cfg repo gc srcDir (prefix ++ "_") destDir showVersion' :: Version -> String showVersion' (maj, min, pat, Nothing) = intercalate "_" [show maj, show min, show pat] showVersion' (maj, min, pat, Just pre) = intercalate "_" [show maj, show min, show pat, pre] --- Tries to find the package directory in the global package cache. findPackageDir :: Config -> Package -> ErrorLogger String findPackageDir cfg pkg = do exists <- liftIOEL $ doesDirectoryExist srcDir if not exists then fail $ "Package " ++ (packageId pkg) ++ " not installed" else return srcDir where srcDir = GC.installedPackageDir cfg pkg