Ticket #7548: typecheck-dir.hs

import System.Directory
import Data.List
import Control.Monad (filterM)
import System.Process

import GHC hiding (flags, ModuleName, RunResult(..))
import GhcMonad (liftIO)
import qualified Config as GHC

assEq name goodMods lm =
  if sort goodMods == sort lm
  then putStrLn $ name ++ " OK"
  else putStrLn $ name ++ " is wrong \n should be " ++ show goodMods ++ "\n is " ++ show lm

getGhcLibdir :: IO FilePath
getGhcLibdir = do
  let ghcbinary = "ghc-" ++ GHC.cProjectVersion
  out <- readProcess ghcbinary ["--print-libdir"] ""
  case lines out of
    [libdir] -> return libdir
    _        -> fail "cannot parse output of ghc --print-libdir"

runFromGhc :: Ghc a -> IO a
runFromGhc a = do
  libdir <- getGhcLibdir
  runGhc (Just libdir) a

ghcComp targets1 = do
    flags0 <- getSessionDynFlags
    (flags1, _, _) <- parseDynamicFlags flags0 [noLoc "-no-user-package-conf"]
    let (hscTarget, ghcLink) = (HscNothing,     NoLink)
        flags = flags1 {
                           hscTarget = hscTarget,
                           ghcLink = ghcLink ,
                           ghcMode    = CompManager,
                           verbosity  = 1
                       }
    setSessionDynFlags flags
    let targetIdFromFile file = TargetFile file Nothing
        addSingle filename = do
              addTarget Target
                { targetId           = targetIdFromFile filename
                , targetAllowObjCode = True
                , targetContents     = Nothing
                }
    mapM_ addSingle targets1
    _loadRes <- load LoadAllTargets
    graph <- getModuleGraph
    let moduleNames = map ms_mod_name graph
    loadedNames <- filterM isLoaded moduleNames
    return $ map moduleNameString loadedNames

main = runFromGhc $ do
    root <- liftIO $ canonicalizePath "tmp"
    liftIO $ writeFile (root ++ "/XXX.hs") "module XXX where\na = 5"
    liftIO $ writeFile (root ++ "/A.hs") "module A where\na = 5"
    liftIO $ writeFile (root ++ "/Wrong.hs") "module Wrong where\nimport A\nasdf"
    liftIO $ writeFile (root ++ "/After.hs") "module After where\nimport XXX\nz = a"

      -- If Wrong.hs refers to XXX, the problem vanishes.

    -- Changing the order of these eliminates the problem:
    let targets1 = [root ++ "/A.hs", root ++ "/XXX.hs"]

    lm <- ghcComp targets1

    liftIO $ assEq "good1" ["A", "XXX"] lm

    let targets2 = [root ++ "/Wrong.hs"]

    lm2 <- ghcComp targets2

    -- Bug: gives ["A"], but only Wrong.hs is wrong, the rest should not be
    -- invalidated.
    liftIO $ assEq "wrong2" ["A", "XXX"] lm2

    let targetIdFromFile file = TargetFile file Nothing
    mapM_ (removeTarget . targetIdFromFile) targets2

    let targets3 = [root ++ "/After.hs"]

    -- Bug: recompiles XXX, but XXX should not be invalidated at all.
    ghcComp targets3