Commit 44629947 authored by Michael Hanus 's avatar Michael Hanus

cpm diff: if module argument is provided, it will definitely be used

parent 1c2392d7
......@@ -16,7 +16,7 @@ module CPM.Diff.Behavior
) where
import AbstractCurry.Build (cmtfunc, cfunc, simpleRule, applyF, pVars, applyE)
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Pretty (defaultOptions, ppCTypeExpr, showCProg)
import AbstractCurry.Select (publicFuncNames, funcName, functions, funcArity
, funcType, argTypes, typeName, types, tconsOfType
, resultType)
......@@ -148,14 +148,16 @@ diffBehavior :: Config
-> Repository
-> GC.GlobalCache
-> ComparisonInfo
-> [String]
-> Maybe [String]
-> IO (ErrorLogger ())
diffBehavior cfg repo gc info mods = getBaseTemp |>=
diffBehavior cfg repo gc info cmods = getBaseTemp |>=
\baseTmp -> findFunctionsToCompare cfg repo gc (infSourceDirA info)
(infSourceDirB info) |>=
(infSourceDirB info) cmods |>=
\(acyCache, funcs, removed) ->
let
filteredFuncs = filter ((`elem` mods) . fst . funcName) funcs
filteredFuncs = maybe funcs
(\mods -> filter ((`elem` mods) . fst . funcName) funcs)
cmods
in case funcs of
[] -> printRemoved removed >> succeedIO ()
_ -> putStrLn infoText >>
......@@ -407,9 +409,10 @@ genTranslatorFunction :: Config
genTranslatorFunction _ _ _ _ _ _ (CTVar _) =
error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++
"Cannot generate translator function for CTVar"
genTranslatorFunction _ _ _ _ _ _ (CFuncType _ _) =
error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++
"Cannot generate translator function for CFuncType"
genTranslatorFunction _ _ _ _ _ _ te@(CFuncType _ _) =
error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++
"Cannot generate translator function for CFuncType:\n" ++
pPrint (ppCTypeExpr defaultOptions te)
genTranslatorFunction cfg repo gc info acy tm t@(CTCons (mod, n) _) =
-- Don't generate another translator if there already is one for the current
-- type.
......@@ -596,22 +599,26 @@ replace' o n (x:xs) | x == o = n : replace' o n xs
--- @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 mods - the modules to compare (if Nothing, compare exported modules)
findFunctionsToCompare :: Config
-> Repository
-> GC.GlobalCache
-> String
-> String
-> String
-> Maybe [String]
-> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
findFunctionsToCompare cfg repo gc dirA dirB = loadPackageSpec dirA |>=
findFunctionsToCompare cfg repo gc dirA dirB cmods = loadPackageSpec dirA |>=
\pkgA -> loadPackageSpec dirB |>=
\pkgB -> resolveAndCopyDependencies cfg repo gc dirA |>=
\depsA -> succeedIO
(Just $ intersect (exportedModules pkgA) (exportedModules pkgB)) |>=
\mods -> log Debug ("Comparing modules: "++ showMods mods) |>
APIDiff.compareModulesInDirs cfg repo gc dirA dirB mods |>=
(maybe (intersect (exportedModules pkgA) (exportedModules pkgB))
id
cmods )|>=
\mods -> log Debug ("Comparing modules: "++ intercalate " " mods) |>
APIDiff.compareModulesInDirs cfg repo gc dirA dirB (Just mods) |>=
\diffs -> log Debug "Finding all functions" |>
findAllFunctions dirA dirB pkgA depsA emptyACYCache |>=
\(acy, allFuncs) ->
findAllFunctions dirA dirB pkgA depsA emptyACYCache mods |>=
\(acy, allFuncs) ->
let
areDiffThenFilter = thenFilter allFuncs Diffing
areHighArityThenFilter = thenFilter allFuncs HighArity
......@@ -626,12 +633,9 @@ findFunctionsToCompare cfg repo gc dirA dirB = loadPackageSpec dirA |>=
filterNonMatchingTypes dirA dirB depsA `areNonMatchingThenFilter`
filterFuncArg dirA dirB depsA `haveFuncArgThenFilter`
liftFilter id
where
showMods Nothing = ""
showMods (Just mods) = intercalate " " mods
emptyFilter :: IO (ErrorLogger (ACYCache, [CFuncDecl]))
-> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
-> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
emptyFilter st = st |>= \(a, fs) -> succeedIO (a, fs, [])
--- Reasons why a function can be excluded from the list of functions to be
......@@ -882,8 +886,11 @@ readCached dir deps acyCache mod = case findModuleDir dir mod acyCache of
--- @param dir the directory where the package is stored
--- @param pkg the package
--- @param deps a list of package dependencies
findAllFunctions :: String -> String -> Package -> [Package] -> ACYCache -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
findAllFunctions dirA dirB pkg deps acyCache = foldEL findForMod (acyCache, []) (exportedModules pkg) |>=
--- @param mods the list of modules to search for public functions
findAllFunctions :: String -> String -> Package -> [Package] -> ACYCache
-> [String] -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
findAllFunctions dirA dirB _ deps acyCache mods =
foldEL findForMod (acyCache, []) mods |>=
\(a, fs) -> succeedIO (a, nub fs)
where
findForMod (acy,_) mod = readCached dirA deps acy mod |>=
......@@ -893,7 +900,8 @@ findAllFunctions dirA dirB pkg deps acyCache = foldEL findForMod (acyCache, [])
funcsA = filter isPublic $ functions progA
funcsB = filter isPublic $ functions progB
in
succeedIO (acy'', nubBy (\a b -> funcName a == funcName b) (funcsA ++ funcsB))
succeedIO (acy'', nubBy (\a b -> funcName a == funcName b)
(funcsA ++ funcsB))
--- Checks whether a function is public.
isPublic :: CFuncDecl -> Bool
......@@ -921,7 +929,8 @@ preparePackages :: Config
-> String
-> Version
-> IO (ErrorLogger ComparisonInfo)
preparePackages cfg repo gc nameA verA nameB verB = GC.tryFindPackage gc nameA verA |>=
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 |>=
......
......@@ -617,27 +617,24 @@ diff opts cfg repo gc =
Just p -> succeedIO (version p)
Just v -> succeedIO v
modules spec = case diffModules opts of
Nothing -> exportedModules spec
Just ms -> ms
diffAPIIfEnabled specDir localSpec diffversion =
if diffAPI opts
then (putStrLn "Running API diff..." >> putStrLn "" >> succeedIO ()) |>
APIDiff.compareModulesFromPackageAndDir cfg repo gc specDir
(name localSpec) diffversion (diffModules opts) |>=
\diffResults ->
let diffOut = APIDiff.showDifferences (map snd diffResults)
(version localSpec) diffversion
in unless (null diffOut) (putStrLn diffOut >> putStrLn "") >>
succeedIO ()
then (putStrLn "Running API diff...\n" >> succeedIO ()) |>
APIDiff.compareModulesFromPackageAndDir cfg repo gc specDir
(name localSpec) diffversion (diffModules opts) |>=
\diffResults ->
let diffOut = APIDiff.showDifferences (map snd diffResults)
(version localSpec) diffversion
in unless (null diffOut) (putStrLn diffOut >> putStrLn "") >>
succeedIO ()
else succeedIO ()
diffBehaviorIfEnabled specDir localSpec diffversion =
if diffBehavior opts
then BDiff.preparePackageAndDir cfg repo gc specDir (name localSpec)
then (putStrLn "Preparing behavior diff...\n" >> succeedIO ()) |>
BDiff.preparePackageAndDir cfg repo gc specDir (name localSpec)
diffversion |>=
\i -> BDiff.diffBehavior cfg repo gc i (modules localSpec)
\i -> BDiff.diffBehavior cfg repo gc i (diffModules opts)
else succeedIO ()
......
......@@ -142,7 +142,8 @@ deleteIfLink target = do
isLink <- isSymlink target
if isLink
then removeSymlink target >> succeedIO ()
else failIO $ "deleteIfLink can only delete links!"
else failIO $ "deleteIfLink can only delete links!\n" ++
"Unexpected target: " ++ target
else succeedIO ()
linkExists :: String -> IO Bool
......
......@@ -136,7 +136,7 @@ behaviorDiffPerformance o = do
genTestProgram :: IO (ErrorLogger ())
genTestProgram = preparePackageDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" |>=
\info -> findFunctionsToCompare defaultConfig emptyRepository GC.emptyCache (infSourceDirA info) (infSourceDirB info) |>=
\info -> findFunctionsToCompare defaultConfig emptyRepository GC.emptyCache (infSourceDirA info) (infSourceDirB info) Nothing |>=
\(acyCache, funcs, _) -> genCurryCheckProgram defaultConfig emptyRepository GC.emptyCache funcs info acyCache |>
succeedIO ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment