Behavior.curry 46.8 KB
Newer Older
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14
--------------------------------------------------------------------------------
--- This module contains functions that compare the behavior of two versions of
--- a package.
--------------------------------------------------------------------------------

module CPM.Diff.Behavior 
  ( ComparisonInfo (..)
  , createBaseTemp
  , getBaseTemp
  , genCurryCheckProgram
  , diffBehavior
  , preparePackageDirs
  , preparePackageAndDir
  , preparePackages
15
  , findFunctionsToCompare
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
16
  ) where
17

18
import AbstractCurry.Build (cfunc, simpleRule, applyF, pVars, applyE)
19 20
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Select (publicFuncNames, funcName, functions, funcArity
21 22
                            , funcType, argTypes, typeName, types, tconsOfType
                            , resultType)
23 24 25
import AbstractCurry.Transform (updCFuncDecl)
import AbstractCurry.Types (CurryProg (..), CFuncDecl (..), CVisibility (..)
                           , CTypeExpr (..), CPattern (..), CExpr (..)
26 27
                           , CTypeDecl (..), CConsDecl (..), CFieldDecl (..)
                           , CVarIName)
28
import Directory (createDirectory, doesDirectoryExist, getTemporaryDirectory)
29
import FilePath ((</>), joinPath)
30
import Function (both)
31
import List (intercalate, intersect, nub, splitOn, isInfixOf, find, delete
32
            , (\\), nubBy)
33
import Maybe (isJust, fromJust, listToMaybe)
34
import Pretty (pPrint, text, indent, vcat, (<+>), (<$$>))
35
import System (system, getEnviron, setEnviron)
36

37
import CPM.AbstractCurry (readAbstractCurryFromPath, readAbstractCurryFromDeps)
38
import CPM.Config (Config)
39
import CPM.Diff.API as APIDiff
40
import CPM.Diff.CurryComments (readComments, getFuncComment)
41 42
import CPM.Diff.Rename (prefixPackageAndDeps)
import CPM.ErrorLogger
43
import CPM.FileUtil (copyDirectory, recreateDirectory, inDirectory)
44 45
import CPM.Package (Package, Version, version, packageId, exportedModules
                   , loadPackageSpec) 
46
import CPM.PackageCache.Global as GC
47
import CPM.PackageCopy (resolveAndCopyDependencies)
48 49
import CPM.Repository (Repository)

50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
-- 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.EasyCheck.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).
105
data ComparisonInfo = ComparisonInfo
106 107 108 109 110 111 112 113 114 115 116
  { 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
  }
117

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
118
--- Create temporary directory for the behavior diff.
119
createBaseTemp :: IO (ErrorLogger String)
120 121 122 123 124
createBaseTemp = getTemporaryDirectory >>= 
  \tmpDir -> 
    let 
      tmp = tmpDir </> "cpm" </> "bdiff" 
    in recreateDirectory tmp >> succeedIO tmp
125

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
126
--- Get temporary directory for the behavior diff.
127
getBaseTemp :: IO (ErrorLogger String)
128 129
getBaseTemp = getTemporaryDirectory >>= 
  \tmpDir -> succeedIO $ tmpDir </> "cpm" </> "bdiff"
130

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
131
--- This message is printed before CurryCheck is executed.
132 133 134 135 136
infoText :: String
infoText = pPrint $ text ("Now running behavior diff. You will be presented" ++
  " with the raw output of CurryCheck. The test functions are named after the" ++
  " functions they compare. If a test fails, the implementations differ.")

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
137 138 139 140 141 142 143
--- 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 mods - a list of modules to compare
144 145 146 147
diffBehavior :: Config 
             -> Repository 
             -> GC.GlobalCache 
             -> ComparisonInfo 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
148
             -> [String]
149
             -> IO (ErrorLogger ())
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
150
diffBehavior cfg repo gc info mods = getBaseTemp |>=
151
  \baseTmp -> findFunctionsToCompare cfg repo gc (infSourceDirA info) (infSourceDirB info) |>=
152
  \(acyCache, funcs, removed) -> 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
153 154 155
    let
      filteredFuncs = filter ((`elem` mods) . fst . funcName) funcs
    in case funcs of
156
      [] -> putStrLn (renderRemoved removed) >> putStrLn "" >> succeedIO () 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
157
      _  -> genCurryCheckProgram cfg repo gc filteredFuncs info acyCache |>
158
            (putStrLn (renderRemoved removed) >> putStrLn "" >> succeedIO ()) |>
159
            (putStrLn infoText >> putStrLn "" >> succeedIO ()) |>
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
160
            callCurryCheck info baseTmp filteredFuncs
161

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
162 163
--- Renders the list of functions that were excluded from the comparison along
--- with reasons for their exclusion.
164 165 166 167 168 169 170 171 172 173
renderRemoved :: [(CFuncDecl, FilterReason)] -> String
renderRemoved rs = pPrint $ text "The following functions were not compared:" <$$>
  vcat (map renderReason rs)
 where
  renderReason (f, r) = indent 4 $ (text $ combineTuple (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 NoCheck = text "Marked NOCOMPARE"
174 175
  reasonText FloatArg = text "Takes Float arguments"
  reasonText FuncArg = text "Takes functions as arguments"
176

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
177
--- Runs CurryCheck on the generated program.
178 179 180 181 182 183 184 185
callCurryCheck :: ComparisonInfo -> String -> [CFuncDecl] -> IO (ErrorLogger ())
callCurryCheck info baseTmp funcs = do
  putStrLn $ "Comparing functions " ++ (intercalate ", " $ map ((flip combineTuple) "." . funcName) funcs)
  oldPath <- getEnviron "CURRYPATH"
  setEnviron "CURRYPATH" $ infDirA info ++ ":" ++ infDirB info
  inDirectory baseTmp $ system "currycheck Compare" 
  setEnviron "CURRYPATH" oldPath
  succeedIO ()
186

187 188 189 190 191 192 193 194
--- 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 
                     -> [CFuncDecl] 
                     -> ComparisonInfo 
195
                     -> ACYCache
196
                     -> IO (ErrorLogger ())
197 198 199
genCurryCheckProgram cfg repo gc funcs info acyCache = getBaseTemp |>=
  \baseTmp -> foldEL translatorGenerator (acyCache, emptyTrans) translateTypes |>=
  \(_, transMap) -> 
200 201 202 203 204 205
    let 
      testFunctions = map (genTestFunction info transMap) funcs
      transFunctions = transFuncs transMap
      prog = CurryProg "Compare" imports [] (testFunctions ++ transFunctions) []
    in
      writeFile (baseTmp </> "Compare.curry") (showCProg prog)
206 207
  >> succeedIO ()
 where
208 209
  allReferencedTypes = nub (
    (concat $ map (argTypes . funcType) funcs) ++ map (resultType . funcType) funcs)
210
  translateTypes = filter (needToTranslatePart info) allReferencedTypes
211
  translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info
212 213 214 215
  mods = map (fst . funcName) funcs
  modsA = map (\mod -> (infPrefixA info) ++ "_" ++ mod) mods
  modsB = map (\mod -> (infPrefixB info) ++ "_" ++ mod) mods
  imports = modsA ++ modsB ++ ["Test.EasyCheck"]
216

217 218 219
--- Generates a test function to compare two versions of the given function.
genTestFunction :: ComparisonInfo -> TransMap -> CFuncDecl -> CFuncDecl
genTestFunction info tm f = 
220
  cfunc (modName, testName) (realArity f) Private newType [
221
    simpleRule vars (applyF ("Test.EasyCheck", "<~>") [callA, callB])]
222 223 224 225 226 227 228 229
 where
  (mod, _) = funcName f
  modName = "Compare"
  testName = "test_" ++ combineTuple (both (replace' '.' '_') $ funcName f) "_"
  localName = snd $ funcName f
  vars = pVars (realArity f)
  modA = (infPrefixA info) ++ "_" ++ mod
  modB = (infPrefixB info) ++ "_" ++ mod
230 231
  instantiatedFunc = instantiateBool $ funcType f
  returnTransform = case findTrans tm (resultType $ instantiatedFunc) of
232 233 234 235 236 237 238 239 240
    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.
241 242
  callA = returnTransform $ applyF (modA, localName) $ map (\(CPVar v) -> CVar v) vars
  callB = applyF (modB, localName) $ map transformedVar $ zip (argTypes $ instantiatedFunc) vars
243 244
  transformedVar (CTVar _, CPVar v) = CVar v
  transformedVar (CFuncType _ _, CPVar v) = CVar v
245 246 247
  transformedVar (t@(CTCons _ _), CPVar v) = case findTrans tm t of
    Just  n -> applyF ("Compare", n) [CVar v]
    Nothing -> CVar v
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
  transformedVar (CTVar _, CPLit _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTVar _, CPComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTVar _, CPAs _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTVar _, CPFuncComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTVar _, CPLazy _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTVar _, CPRecord _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPLit _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPAs _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPFuncComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPLazy _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CFuncType _ _, CPRecord _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPLit _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPAs _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPFuncComb _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPLazy _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
  transformedVar (CTCons _ _, CPRecord _ _) = error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach"
266 267 268 269 270
  newType = mapTypes info $ genTestFuncType f

--- Checks if any part of the given type needs to be translated using a 
--- translator function.
needToTranslatePart :: ComparisonInfo -> CTypeExpr -> Bool
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
271
needToTranslatePart _    (CTVar _) = False
272 273
needToTranslatePart info (CFuncType e1 e2) = needToTranslatePart info e1 || needToTranslatePart info e2
needToTranslatePart info (CTCons n es) = isMappedType info n || any (needToTranslatePart info) es
274

275 276
--- Checks if the module of the given type is one of the mapped modules, i.e.
--- one that is present in two versions.
277 278 279
isMappedType :: ComparisonInfo -> (String, String) -> Bool
isMappedType info (mod, _) = isJust $ lookup mod (infModMapA info)

280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
--- 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. Please 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")] [
      CCons ("Prelude", "[]") Public []
    , CCons ("Prelude", ":") Public [CTVar (0, "a"), CTCons ("Prelude", "[]") [CTVar (0, "a")]]]
  ("Prelude", "(,)") -> Just $ CType ("Prelude", "(,)") Public [(0, "a"), (1, "b")] [
    CCons ("Prelude", "(,)") Public [CTVar (0, "a"), CTVar (1, "b")]]
318 319 320 321
  ("Prelude", "(,,)") -> Just $ CType ("Prelude", "(,,)") Public [(0, "a"), (1, "b"), (2, "c")] [
    CCons ("Prelude", "(,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c")]]
  ("Prelude", "(,,,)") -> Just $ CType ("Prelude", "(,,,)") Public [(0, "a"), (1, "b"), (2, "c"), (3, "d")] [
    CCons ("Prelude", "(,,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c"), CTVar (3, "d")]]
322 323
  _ -> Nothing

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
324 325 326
--- The ACYCache caches the AbstractCurry representations of Curry modules,
--- specific to the directory it is stored in (to support multiple versions of a
--- module).
327
data ACYCache = ACYCache [(String, [(String, CurryProg)])]
328

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
329
--- An empty ACYCache.
330 331 332
emptyACYCache :: ACYCache
emptyACYCache = ACYCache []

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
333
--- Finds a module inside an ACYCache, regardless of its directory.
334
findModule :: String -> ACYCache -> Maybe CurryProg
335 336 337 338
findModule mod (ACYCache ps) = case lookup mod ps of
  Nothing -> Nothing
  Just ms -> listToMaybe $ map snd ms

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
339
--- Finds a module inside the ACYCache that was read from a specific directory.
340 341 342 343
findModuleDir :: String -> String -> ACYCache -> Maybe CurryProg
findModuleDir dir mod (ACYCache ps) = case lookup mod ps of
  Nothing -> Nothing
  Just ms -> lookup dir ms
344

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
345
--- Adds a module to the ACYCache without a directory.
346 347 348
addModule :: String -> CurryProg -> ACYCache -> ACYCache
addModule mod p (ACYCache ps) = case lookup mod ps of
  Just  _ -> ACYCache ps
349 350
  Nothing -> ACYCache $ (mod, [("", p)]):ps

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
351
--- Adds a module to the ACYCache with a directory.
352 353 354 355 356 357
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 
358

359 360 361 362 363 364 365 366 367 368 369 370
--- 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 
371
                      -> ACYCache
372 373
                      -> TransMap 
                      -> CTypeExpr 
374 375 376
                      -> IO (ErrorLogger (ACYCache, TransMap))
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"
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
377
genTranslatorFunction cfg repo gc info acy tm t@(CTCons (mod, n) _) = 
378 379
  -- Don't generate another translator if there already is one for the current
  -- type.
380
  if isJust $ findTrans tm t' then succeedIO (acy, tm) else findType |>=
381 382
  -- 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.
383
  \(acy', typeDecl) -> (succeedIO $ instantiate typeDecl t') |>=
384 385 386
  -- 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.
387
  \instTypeDecl -> (succeedIO $ addEntry tm t') |>=
388 389
  \(tm', name) -> foldEL (uncurry $ genTranslatorFunction cfg repo gc info) (acy', tm') (transExprs instTypeDecl) |>= 
  \(acy'', tm'') -> 
390
    let
391 392
      aType = prefixMappedTypes (infPrefixA info) t'
      bType = prefixMappedTypes (infPrefixB info) t'
393 394
      fType = CFuncType aType bType
      fName = ("Compare", name)
395 396
      mapIfNeeded modMap m = if isMappedType info (m, "")
        then fromJust $ lookup m modMap
397
        else m
398 399
      mapIfNeededA = mapIfNeeded (infModMapA info)
      mapIfNeededB = mapIfNeeded (infModMapB info)
400

401 402 403 404 405 406
      transformer (i, CTVar _) = CVar (i, "x" ++ (show i))
      transformer (i, CFuncType _ _) = CVar (i, "x" ++ (show i))
      transformer (i, e@(CTCons _ _)) = case findTrans tm'' e of
        Nothing -> CVar (i, "x" ++ (show i))
        Just tn -> applyF ("Compare", tn) [CVar (i, "x" ++ (show i))]

407 408 409 410 411
      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
412 413 414 415
      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)
416

417 418 419
      synRule e = simpleRule [CPVar (0, "x0")] call
       where
        call = transformer (0, e)
420
    in case instTypeDecl of
421
      CType _ _ _ cs -> succeedIO $ (acy'', addFunc tm'' (cfunc fName 1 Public fType (map ruleForCons cs)))
422
      CTypeSyn _ _ _ e -> succeedIO $ (acy'', addFunc tm'' (cfunc fName 1 Public fType [synRule e]))
423
      CNewType _ _ _ c -> succeedIO $ (acy'', addFunc tm'' (cfunc fName 1 Public fType [ruleForCons c]))
424
 where
425 426 427 428
  -- Since our test functions always use polymorphic types instantiated to Bool,
  -- we generate our translator functions for Bool-instantiated types as well.
  t' = instantiateBool t

429 430
  -- Finds all type expressions in the instantiated constructors that contain 
  -- types that need to be translated.
431 432 433 434 435 436
  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
437 438

  -- Recursively prefixes those types which are present in two versions.
439 440 441
  prefixMappedTypes pre (CTCons (mod', n') te') = if isMappedType info (mod, n')
    then CTCons (pre ++ "_" ++ mod', n') $ map (prefixMappedTypes pre) te'
    else CTCons (mod', n') $ map (prefixMappedTypes pre) te'
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
442
  prefixMappedTypes _   (CTVar v) = CTVar v
443 444 445 446
  prefixMappedTypes pre (CFuncType e1 e2) = CFuncType (prefixMappedTypes pre e1) (prefixMappedTypes pre e2)

  -- Finds the type declaration for the type referenced in the type expression.
  findType = case predefinedType (mod, n) of
447 448 449 450 451
    Just ty -> succeedIO (acy, ty)
    Nothing -> (case findModule mod acy of
      Just  p -> succeedIO $ p
      Nothing   -> resolveAndCopyDependencies cfg repo gc (infSourceDirA info) |>=
        \deps -> (readAbstractCurryFromDeps (infSourceDirA info) deps mod >>= succeedIO)) |>=
452 453
      \prog -> case filter ((== n) . snd . typeName) (types prog) of
        []    -> failIO $ "No type called '" ++ n ++ "' in module '" ++ mod ++ "'"
454
        (x:_) -> succeedIO (addModule mod prog acy, x)
455

456 457 458 459 460 461 462 463 464
--- 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 vm (CTCons n es) = CTCons n $ map (maybeReplaceVar vm) es
maybeReplaceVar vm (CFuncType e1 e2) = CFuncType (maybeReplaceVar vm e1) (maybeReplaceVar vm e2)

465 466 467 468 469 470 471
--- 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 (CType n v vs cs) (CTCons _ es) = CType n v vs $ map cons cs
 where
  varMap = zip vs es
472
  cons (CCons n' v' es') = CCons n' v' $ map (maybeReplaceVar varMap) es'
473
  cons (CRecord n' v' fs') = CRecord n' v' $ map maybeReplaceField fs'
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489
  maybeReplaceField (CField n'' v'' e) = CField n'' v'' $ maybeReplaceVar varMap e
instantiate (CTypeSyn n v vs e) (CTCons _ es) = CTypeSyn n v vs $ maybeReplaceVar varMap e
 where
  varMap = zip vs es
instantiate (CNewType n v vs c) (CTCons _ es) = CNewType n v vs $ cons c
 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 (CType _ _ _ _) (CTVar _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTVar"
instantiate (CTypeSyn _ _ _ _) (CTVar _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTVar"
instantiate (CNewType _ _ _ _) (CTVar _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTVar"
instantiate (CType _ _ _ _) (CFuncType _ _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType"
instantiate (CTypeSyn _ _ _ _) (CFuncType _ _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType"
instantiate (CNewType _ _ _ _) (CFuncType _ _) = error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType"
490 491 492

--- Recursively transforms all module names of all constructor references in the
--- type expression into the module names of version A.
493 494
mapTypes :: ComparisonInfo -> CTypeExpr -> CTypeExpr
mapTypes info (CFuncType a b) = CFuncType (mapTypes info a) (mapTypes info b)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
495
mapTypes _  v@(CTVar _) = v
496 497 498 499 500 501 502 503
mapTypes info (CTCons (m, n) ts) = case lookup m mapA of
  Nothing -> CTCons (m, n) $ map (mapTypes info) ts
  Just m' -> CTCons (m', n) $ map (mapTypes info) ts
 where
  mapA = infModMapA info

realArity :: CFuncDecl -> Int
realArity (CFunc _ _ _ t _) = arityOfType t
504 505 506 507 508 509
realArity (CmtFunc _ _ _ _ t _) = arityOfType t

arityOfType :: CTypeExpr -> Int
arityOfType (CFuncType _ b) = 1 + arityOfType b
arityOfType (CTVar _) = 0
arityOfType (CTCons _ _) = 0
510

511
--- Generates a function type for the test function by replacing the result 
512 513
--- type with `Test.EasyCheck.Prop`. Also instantiates polymorphic types to
--- Bool.
514 515
genTestFuncType :: CFuncDecl -> CTypeExpr
genTestFuncType f = replaceResultType t (CTCons ("Test.EasyCheck", "Prop") [])
516 517 518 519 520 521
  where t = instantiateBool $ funcType f

instantiateBool :: CTypeExpr -> CTypeExpr
instantiateBool (CTVar _) = CTCons ("Prelude", "Bool") []
instantiateBool (CTCons n ts) = CTCons n $ map instantiateBool ts
instantiateBool (CFuncType a b) = CFuncType (instantiateBool a) (instantiateBool b)
522

523
--- Replaces the result type of a function type.
524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
replaceResultType :: CTypeExpr -> CTypeExpr -> CTypeExpr
replaceResultType (CFuncType a (CTVar _)) z = CFuncType a z
replaceResultType (CFuncType a (CTCons _ _)) z = CFuncType a z
replaceResultType (CFuncType a b@(CFuncType _ _)) z = CFuncType a (replaceResultType b z)
replaceResultType (CTVar _) z = z
replaceResultType (CTCons _ _) z = z

combineTuple :: (String, String) -> String -> String
combineTuple (a, b) s = a ++ s ++ b

replace' :: a -> a -> [a] -> [a]
replace' _ _ [] = []
replace' o n (x:xs) | x == o = n : replace' o n xs
                    | otherwise = x : replace' o n xs

539 540 541 542 543 544 545 546 547 548 549 550 551 552 553
--- 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
findFunctionsToCompare :: Config 
                       -> Repository 
                       -> GC.GlobalCache 
                       -> String 
                       -> String 
554
                       -> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
555 556 557
findFunctionsToCompare cfg repo gc dirA dirB = loadPackageSpec dirA |>=
  \pkgA -> loadPackageSpec dirB |>= 
  \pkgB -> resolveAndCopyDependencies cfg repo gc dirA |>=
558
  \depsA -> succeedIO (Just $ intersect (exportedModules pkgA) (exportedModules pkgB)) |>=
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
559
  \mods -> log Debug "Comparing modules" |>
560
  APIDiff.compareModulesInDirs cfg repo gc dirA dirB mods |>=
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
561
  \diffs -> log Debug "Finding all functions" |>
562
  findAllFunctions dirA dirB pkgA depsA emptyACYCache |>=
563 564 565 566 567 568
  \(acy, allFuncs) -> 
    let
      areDiffThenFilter = thenFilter allFuncs Diffing
      areHighArityThenFilter = thenFilter allFuncs HighArity
      areNoCheckThenFilter = thenFilter allFuncs NoCheck
      areNonMatchingThenFilter = thenFilter allFuncs NonMatchingTypes
569 570
      haveFloatArgThenFilter = thenFilter allFuncs FloatArg
      haveFuncArgThenFilter = thenFilter allFuncs FuncArg 
571 572 573 574 575
    in
      emptyFilter ((liftFilter $ filterDiffingFunctions diffs) acy allFuncs) `areDiffThenFilter`
      liftFilter filterHighArity `areHighArityThenFilter`
      filterNoCheck dirA dirB depsA `areNoCheckThenFilter`
      filterNonMatchingTypes dirA dirB depsA `areNonMatchingThenFilter`
576 577
      filterFloatArg dirA dirB depsA `haveFloatArgThenFilter`
      filterFuncArg dirA dirB depsA `haveFuncArgThenFilter`
578 579
      liftFilter id 

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
580 581
emptyFilter :: IO (ErrorLogger (ACYCache, [CFuncDecl])) 
            -> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
582 583
emptyFilter st = st |>= \(a, fs) -> succeedIO (a, fs, [])

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
584 585
--- Reasons why a function can be excluded from the list of functions to be 
--- compared.
586 587 588 589 590
data FilterReason = NoReason
                  | HighArity
                  | NoCheck
                  | NonMatchingTypes
                  | Diffing
591 592
                  | FloatArg
                  | FuncArg
593

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
594 595
--- Chain filter functions and mark the ones removed by the previous filter 
--- with a given reason.
596 597 598 599 600 601 602 603 604 605 606
thenFilter :: [CFuncDecl]
           -> FilterReason 
           -> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
           -> (ACYCache -> [CFuncDecl] -> IO (ErrorLogger (ACYCache, [CFuncDecl]))) 
           -> IO (ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]))
thenFilter allFuncs r st f = 
  st |>= 
  \(a, fs, rm) -> f a fs |>= 
  \(a', fs') -> succeedIO (a', fs', rm ++ zip (findMissing rm fs) (repeat r))
 where
  findMissing rm fs = (allFuncs \\ (map fst rm)) \\ fs
607

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
608 609 610 611
--- Lifts a simple filter to a filter that executes inside the IO monad and 
--- takes an ACYCache.
liftFilter :: ([CFuncDecl] -> [CFuncDecl]) 
           -> (ACYCache -> [CFuncDecl] -> IO (ErrorLogger (ACYCache, [CFuncDecl])))
612
liftFilter f = \a fs -> succeedIO (a, f fs)
613

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
614 615 616 617
--- Excludes those functions which take a Float argument, either directly or
--- via a nested type.
filterFloatArg :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] 
               -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
618 619 620 621 622 623
filterFloatArg = filterFuncsDeep checkFloat
 where
  checkFloat (CFuncType _ _) = False
  checkFloat (CTVar _) = False
  checkFloat (CTCons n _) = n == ("Prelude", "Float")

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
624 625 626 627
--- Excludes those functions which take a functional argument, either directly 
--- or via a nested type.
filterFuncArg :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] 
              -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
628 629 630 631 632 633
filterFuncArg = filterFuncsDeep checkFunc
 where
  checkFunc (CFuncType _ _) = True
  checkFunc (CTVar _) = False
  checkFunc (CTCons _ _) = False

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
634 635 636 637 638
--- 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] 
                -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
639 640
filterFuncsDeep x dirA _ deps acy allFuncs = foldEL checkFunc (acy, [], []) allFuncs |>=
  \(acy', _, fns) -> succeedIO (acy', fns)
641 642 643 644 645
 where
  findType n m = case predefinedType n of
    Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m
    Just ty -> Just ty

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
646
  checkFunc (a, c, fs) f = (foldEL checkTypeExpr (a, c, False) $ argTypes $ funcType f) |>=
647 648 649
    \(a', c', r) -> if r
      then succeedIO (a', c', fs)
      else succeedIO (a', c', f:fs)
650 651 652 653 654 655 656 657 658 659 660 661 662 663

  checkTypeExpr (a, c, r) t@(CFuncType e1 e2) = if t `elem` c
    then succeedIO (a, c, r)
    else if x t
      then succeedIO (a, c, True)
      else checkTypeExpr (a, c, r) e1 |>=
        \(a', c', r') -> checkTypeExpr (a', e1:c', r') e2 |>=
        \(a'', c'', r'') -> succeedIO (a'', e2:c'', r || r' || r'')
  checkTypeExpr (a, c, r) (CTVar _) = succeedIO (a, c, r)
  checkTypeExpr (a, c, r) t@(CTCons n@(mod, _) es) = if t `elem` c
    then succeedIO (a, c, r)
    else if x t
      then succeedIO (a, c, True)
      else foldEL checkTypeExpr (a, c, r) es |>=
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
664
        \(a', c', _) -> readCached dirA deps a' mod |>=
665 666 667 668 669 670 671 672 673 674 675 676 677
        \(a'', prog) -> case findType n prog of
          Nothing -> failIO $ "Type '" ++ (show n) ++ "' not found."
          Just t' -> checkType a'' (t:c') t' |>=
            \(a''', c'', r'') -> succeedIO (a''', c'', r'')

  checkType a ts (CType _ _ _ cs) = foldEL 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) = foldEL checkTypeExpr (a, ts, r) es
  checkCons (a, ts, r) (CRecord _ _ fs) = let es = map (\(CField _ _ e) -> e) fs in
    foldEL checkTypeExpr (a, ts, r) es

678
--- Filters out functions marked with the NOCHECK pragma. 
679 680
filterNoCheck :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
filterNoCheck dirA dirB _ a fs = mapIO (readComments . modPath dirA) modules >>= 
681 682 683 684 685
  \allCommentsA -> mapIO (readComments . modPath dirB) modules >>=
  \allCommentsB -> 
    let
      commentsA = funcsWithComments $ zip modules allCommentsA
      commentsB = funcsWithComments $ zip modules allCommentsB
686
     in succeedIO $ (a, filter (not . noCheck commentsA commentsB) fs)
687
 where
688
  modules = nub $ map (fst . funcName) fs
689 690 691 692 693 694 695 696 697 698 699 700 701 702 703
  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
  noCheck cmtsA cmtsB f = noCheck' cmtsA f || noCheck' cmtsB f
  -- Check if NOCHECK is mentioned in the comments
  noCheck' cmts f = case lookup f cmts of
    Nothing -> False
    Just  c -> "NOCHECK" `isInfixOf` c
704 705 706 707 708

--- 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 . funcType) 
709

710 711 712 713 714
--- 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
715
filterDiffingFunctions :: [(String, Differences)] -> [CFuncDecl] -> [CFuncDecl]
716
filterDiffingFunctions diffs allFuncs = nub $ concatMap filterModule modules
717
 where
718
  modules = nub $ map (fst . funcName) allFuncs
719 720
  diffsForModule mod = case lookup mod diffs of
    Nothing -> []
721
    Just (_, funcDiffs, _, _) -> map funcDiffName funcDiffs
722 723 724
  funcDiffName (Addition f) = funcName f
  funcDiffName (Removal  f) = funcName f
  funcDiffName (Change _ f) = funcName f
725 726
  filterModule mod = filter (not . (`elem` (diffsForModule mod)) . funcName) (funcsForModule mod)
  funcsForModule mod = filter ((== mod) . fst . funcName) allFuncs
727

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
728 729 730 731
--- Excludes those functions whose types do not match in both versions. Checks
--- nested types.
filterNonMatchingTypes :: String -> String -> [Package] -> ACYCache 
                       -> [CFuncDecl] -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
732
filterNonMatchingTypes dirA dirB deps acyCache allFuncs =
733 734
  foldEL funcTypesCompatible (acyCache, [], []) allFuncs |>=
  \(acy, _, fns) -> succeedIO (acy, fns)
735 736 737
 where
  allTypes f = let ft = funcType f in (resultType ft):(argTypes ft)
  onlyCons = filter isConsType
738 739 740 741 742 743 744 745
  funcTypesCompatible (a, seen, fs) f = (foldEL typesCompatible (a, seen, True) $ onlyCons $ allTypes f) |>=
    \(a', seen', c) -> if c
      then succeedIO (a', seen', f:fs)
      else succeedIO (a', seen', fs)
  typesCompatible (a, seen, r) t = case lookup t seen of
    Just b  -> succeedIO (a, seen, b && r)
    Nothing -> typesEqual t dirA dirB deps a [] |>=
      \(a', r') -> succeedIO (a', ((t, r'):seen), r' && r)
746 747 748 749

--- 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] -> IO (ErrorLogger (ACYCache, Bool))
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
750
typesEqual t@(CTCons n _) dirA dirB deps acyCache checked = 
751 752 753 754 755 756 757 758 759 760
  if t `elem` checked
    then succeedIO (acyCache, True)
    else readCached dirA deps acyCache mod |>=
      \(acy',  modA) -> readCached dirB deps acy' mod |>=
      \(acy'', modB) -> 
        let
          typeA = findType modA
          typeB = findType modB
        in typesEqual' typeA typeB acy''
 where
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
761
  (mod, _) = n
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
  findType m = case predefinedType n of
    Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m
    Just ty -> Just ty
  typesEqual' :: Maybe CTypeDecl -> Maybe CTypeDecl -> ACYCache -> IO (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 foldEL (\(a, r) (c1, c2) -> consEqual a c1 c2 |>= \(a', r') -> succeedIO (a', r && r')) (acy, True) (zip cs1 cs2)
      else succeedIO (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 (t:checked)
        else succeedIO (acy, True)
      else succeedIO (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 succeedIO (acy, False)
  typesEqual' (Just (CType _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = succeedIO (acy, False)
  typesEqual' (Just (CType _ _ _ _)) (Just (CNewType _ _ _ _)) acy = succeedIO (acy, False) 
  typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CType _ _ _ _)) acy = succeedIO (acy, False)
  typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CNewType _ _ _ _)) acy = succeedIO (acy, False)
  typesEqual' (Just (CNewType _ _ _ _)) (Just (CType _ _ _ _)) acy = succeedIO (acy, False)
  typesEqual' (Just (CNewType _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = succeedIO (acy, False)
  typesEqual' Nothing (Just _) acy = succeedIO (acy, False)
  typesEqual' (Just _) Nothing acy = succeedIO (acy, False)
  typesEqual' Nothing  Nothing acy = succeedIO (acy, False)
  
  consEqual :: ACYCache -> CConsDecl -> CConsDecl -> IO (ErrorLogger (ACYCache, Bool))
  consEqual acy (CCons _ _ es1) (CCons _ _ es2) = 
    foldEL esEqual (acy, True) (zip es1 es2)
   where
    esEqual (a, r) (e1, e2) = if e1 == e2
      then if isConsType e1
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
796
        then typesEqual e1 dirA dirB deps a (t:checked)
797 798 799 800 801
        else succeedIO (acy, r)
      else succeedIO (acy, False)
  consEqual acy (CRecord _ _ fs1) (CRecord _ _ fs2) = 
    foldEL fEqual (acy, True) (zip fs1 fs2)
   where
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
802
    fEqual (a, r) (f1@(CField _ _ e1), f2@(CField _ _ _)) = if f1 == f2
803
      then if isConsType e1
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
804
        then typesEqual e1 dirA dirB deps a (t:checked)
805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821
        else succeedIO (acy, r)
      else succeedIO (acy, False)
  consEqual acy (CCons _ _ _) (CRecord _ _ _) = succeedIO (acy, False)
  consEqual acy (CRecord _ _ _) (CCons _ _ _) = succeedIO (acy, False)
typesEqual (CTVar _) _ _ _ _ _ = failIO "typesEqual called on CTVar"
typesEqual (CFuncType _ _) _ _ _ _ _ = failIO "typesEqual called on CFuncType"

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

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
822 823 824
--- Reads a module in AbstractCurry form.
readCached :: String -> [Package] -> ACYCache -> String 
           -> IO (ErrorLogger (ACYCache, CurryProg))
825 826 827 828 829
readCached dir deps acyCache mod = case findModuleDir dir mod acyCache of
  Just  p -> succeedIO (acyCache, p)
  Nothing -> readAbstractCurryFromDeps dir deps mod >>= 
    \prog -> succeedIO (addModuleDir dir mod prog acyCache, prog)

830 831 832 833 834 835
--- Reads all modules of the given package and finds all public functions in all
--- of those modules.
---
--- @param dir the directory where the package is stored
--- @param pkg the package
--- @param deps a list of package dependencies
836 837
findAllFunctions :: String -> String -> Package -> [Package] -> ACYCache -> IO (ErrorLogger (ACYCache, [CFuncDecl]))
findAllFunctions dirA dirB pkg deps acyCache = foldEL findForMod (acyCache, []) (exportedModules pkg) |>=
838
  \(a, fs) -> succeedIO (a, nub fs)
839
 where
840 841 842 843 844 845 846 847
  findForMod (acy, acc) mod = readCached dirA deps acy mod |>=
    \(acy', progA)  -> readCached dirB deps acy mod |>=
    \(acy'', progB) -> 
      let 
        funcsA = filter isPublic $ functions progA
        funcsB = filter isPublic $ functions progB
      in
        succeedIO (acy'', nubBy (\a b -> funcName a == funcName b) (funcsA ++ funcsB))
848

849
--- Checks whether a function is public.
850 851 852 853 854
isPublic :: CFuncDecl -> Bool
isPublic (CFunc _ _ Public _ _) = True
isPublic (CFunc _ _ Private _ _) = False
isPublic (CmtFunc _ _ _ Public _ _) = True
isPublic (CmtFunc _ _ _ Private _ _) = False
855

856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874
--- 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 
                -> IO (ErrorLogger ComparisonInfo)
875
preparePackages cfg repo gc nameA verA nameB verB = GC.tryFindPackage gc nameA verA |>=
876
  \pkgA -> findPackageDir cfg pkgA |>=
877
  \dirA -> GC.tryFindPackage gc nameB verB |>=
878 879 880
  \pkgB -> findPackageDir cfg pkgB |>=
  \dirB -> preparePackageDirs cfg repo gc dirA dirB

881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897
--- 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 
                     -> IO (ErrorLogger ComparisonInfo)
898
preparePackageAndDir cfg repo gc dirA nameB verB = GC.tryFindPackage gc nameB verB |>=
899 900 901
  \pkgB -> findPackageDir cfg pkgB |>=
  \dirB -> preparePackageDirs cfg repo gc dirA dirB

902 903 904 905 906 907 908 909 910 911 912 913 914 915 916
--- 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 
                   -> IO (ErrorLogger ComparisonInfo)
917
preparePackageDirs cfg repo gc dirA dirB = createBaseTemp |>=
918 919 920 921
  \baseTmp -> loadPackageSpec dirA |>=
  \specA -> loadPackageSpec dirB |>= 
  \specB -> log Debug ("Transforming " ++ (packageId specA) ++ " from " ++ dirA) |>
  log Debug ("Transforming " ++ (packageId specB) ++ " from " ++ dirB) |>
922
  copyAndPrefixPackage cfg repo gc dirA (versionPrefix specA) baseTmp |>=
923 924
  \modMapA -> copyAndPrefixPackage cfg repo gc dirB (versionPrefix specB) baseTmp |>=
  \modMapB -> succeedIO $ ComparisonInfo 
925 926
    { infPackageA = specA
    , infPackageB = specB
927 928
    , infDirA = (baseTmp </> ("dest_" ++ (versionPrefix specA)))
    , infDirB = (baseTmp </> ("dest_" ++ (versionPrefix specB)))
929 930 931
    , infSourceDirA = (baseTmp </> ("src_" ++ (versionPrefix specA)))
    , infSourceDirB = (baseTmp </> ("src_" ++ (versionPrefix specB)))
    , infPrefixA = versionPrefix specA
932 933 934
    , infPrefixB = versionPrefix specB
    , infModMapA = modMapA
    , infModMapB = modMapB }
935 936 937

versionPrefix :: Package -> String
versionPrefix pkg = "V_" ++ (showVersion' $ version pkg)
938

939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
--- 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 
copyAndPrefixPackage :: Config 
                     -> Repository 
                     -> GC.GlobalCache 
                     -> String 
                     -> String 
                     -> String 
                     -> IO (ErrorLogger [(String, String)])
956
copyAndPrefixPackage cfg repo gc pkgDir prefix baseTmp = 
957 958
  copyDirectory pkgDir srcDir >> createDirectory destDir >> succeedIO () |>
  prefixPackageAndDeps cfg repo gc srcDir (prefix ++ "_") destDir 
959 960 961 962 963 964 965 966 967 968
 where
  srcDir = baseTmp </> ("src_" ++ prefix)
  destDir = baseTmp </> ("dest_" ++ prefix)

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]

969
--- Tries to find the package directory in the global package cache.
970 971 972 973 974 975 976 977
findPackageDir :: Config -> Package -> IO (ErrorLogger String)
findPackageDir cfg pkg = do
  exists <- doesDirectoryExist srcDir
  if not exists
    then failIO $ "Package " ++ (packageId pkg) ++ " not installed"
    else succeedIO srcDir
 where
  srcDir = GC.installedPackageDir cfg pkg