Ticket #7548: typecheck-dir.hs

File typecheck-dir.hs, 2.7 KB (added by MikolajKonarski, 16 months ago)
Line 
1import System.Directory
2import Data.List
3import Control.Monad (filterM)
4import System.Process
5
6import GHC hiding (flags, ModuleName, RunResult(..))
7import GhcMonad (liftIO)
8import qualified Config as GHC
9
10assEq name goodMods lm =
11  if sort goodMods == sort lm
12  then putStrLn $ name ++ " OK"
13  else putStrLn $ name ++ " is wrong \n should be " ++ show goodMods ++ "\n is " ++ show lm
14
15getGhcLibdir :: IO FilePath
16getGhcLibdir = do
17  let ghcbinary = "ghc-" ++ GHC.cProjectVersion
18  out <- readProcess ghcbinary ["--print-libdir"] ""
19  case lines out of
20    [libdir] -> return libdir
21    _        -> fail "cannot parse output of ghc --print-libdir"
22
23runFromGhc :: Ghc a -> IO a
24runFromGhc a = do
25  libdir <- getGhcLibdir
26  runGhc (Just libdir) a
27
28ghcComp targets1 = do
29    flags0 <- getSessionDynFlags
30    (flags1, _, _) <- parseDynamicFlags flags0 [noLoc "-no-user-package-conf"]
31    let (hscTarget, ghcLink) = (HscNothing,     NoLink)
32        flags = flags1 {
33                           hscTarget = hscTarget,
34                           ghcLink = ghcLink ,
35                           ghcMode    = CompManager,
36                           verbosity  = 1
37                       }
38    setSessionDynFlags flags
39    let targetIdFromFile file = TargetFile file Nothing
40        addSingle filename = do
41              addTarget Target
42                { targetId           = targetIdFromFile filename
43                , targetAllowObjCode = True
44                , targetContents     = Nothing
45                }
46    mapM_ addSingle targets1
47    _loadRes <- load LoadAllTargets
48    graph <- getModuleGraph
49    let moduleNames = map ms_mod_name graph
50    loadedNames <- filterM isLoaded moduleNames
51    return $ map moduleNameString loadedNames
52
53main = runFromGhc $ do
54    root <- liftIO $ canonicalizePath "tmp"
55    liftIO $ writeFile (root ++ "/XXX.hs") "module XXX where\na = 5"
56    liftIO $ writeFile (root ++ "/A.hs") "module A where\na = 5"
57    liftIO $ writeFile (root ++ "/Wrong.hs") "module Wrong where\nimport A\nasdf"
58    liftIO $ writeFile (root ++ "/After.hs") "module After where\nimport XXX\nz = a"
59
60      -- If Wrong.hs refers to XXX, the problem vanishes.
61
62    -- Changing the order of these eliminates the problem:
63    let targets1 = [root ++ "/A.hs", root ++ "/XXX.hs"]
64
65    lm <- ghcComp targets1
66
67    liftIO $ assEq "good1" ["A", "XXX"] lm
68
69    let targets2 = [root ++ "/Wrong.hs"]
70
71    lm2 <- ghcComp targets2
72
73    -- Bug: gives ["A"], but only Wrong.hs is wrong, the rest should not be
74    -- invalidated.
75    liftIO $ assEq "wrong2" ["A", "XXX"] lm2
76
77    let targetIdFromFile file = TargetFile file Nothing
78    mapM_ (removeTarget . targetIdFromFile) targets2
79
80    let targets3 = [root ++ "/After.hs"]
81
82    -- Bug: recompiles XXX, but XXX should not be invalidated at all.
83    ghcComp targets3