Fix fileModuleName not working on CPP modules given by path

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -214,9 +214,7 @@ updateHomeModuleGraph' env smp0 = do
       preprocess' :: m (Maybe (DynFlags, FilePath))
       preprocess' = do
         let fn = mpPath mp
-        ep <- liftIO $ withLogger' env $ \setDf -> let
+        ep <- preprocessFile env fn
-              env' = env { hsc_dflags = setDf (hsc_dflags env) }
-           in preprocess env' (fn, Nothing)
         case ep of
           Right (_, x) -> return $ Just x
           Left errs -> do
@@ -240,13 +238,25 @@ updateHomeModuleGraph' env smp0 = do
                    $ map unLoc hsmodImports
            liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
 
-fileModuleName :: HscEnv
+preprocessFile :: MonadIO m =>
-               -> FilePath
+  HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
-               -> IO (Either ErrorMessages (Maybe ModuleName))
+preprocessFile env file =
+  liftIO $ withLogger' env $ \setDf -> do
+    let env' = env { hsc_dflags = setDf (hsc_dflags env) }
+    preprocess env' (file, Nothing)
+
+fileModuleName ::
+  HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName))
 fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do
-    src <- readFile fn
+    ep <- preprocessFile env fn
-    case parseModuleHeader src (hsc_dflags env) fn of
+    case ep of
-      Left errs -> return (Left errs)
+      Left errs -> do
-      Right (_, lmdl) -> do
+        return $ Left errs
-        let HsModule {..} = unLoc lmdl
+      Right (_warns, (dflags, procdFile)) -> do
-        return $ Right $ unLoc <$> hsmodName
+        src <- readFile procdFile
+        case parseModuleHeader src dflags procdFile of
+          Left errs -> do
+            return $ Left $ errBagToStrList env errs
+          Right (_, lmdl) -> do
+            let HsModule {..} = unLoc lmdl
+            return $ Right $ unLoc <$> hsmodName

Language/Haskell/GhcMod/Logger.hs

@@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Logger (
   , withLogger'
   , checkErrorPrefix
   , errsToStr
+  , errBagToStrList
   ) where
 
 import Control.Arrow
@@ -93,6 +94,13 @@ withLogger' env action = do
         GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
      ]
 
+errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
+errBagToStrList env errs = let
+    dflags = hsc_dflags env
+    pu = icPrintUnqual dflags (hsc_IC env)
+    st = mkUserStyle pu AllTheWay
+ in errsToStr dflags st $ bagToList errs
+
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.

Language/Haskell/GhcMod/Target.hs

@@ -27,6 +27,7 @@ import SysTools
 import DynFlags
 import HscMain
 import HscTypes
+import Bag (bagToList)
 
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Monad.Types
@@ -36,9 +37,11 @@ import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 
+
 import Data.Maybe
 import Data.Monoid
 import Data.Either
@@ -274,7 +277,7 @@ sandboxOpts crdl =
     (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
 
 resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
-    => Maybe [Either FilePath ModuleName] -- ^ Updated modules
+    => Maybe [CompilationUnit] -- ^ Updated modules
     -> GmComponent GMCRaw (Set ModulePath)
     -> m (GmComponent GMCResolved (Set ModulePath))
 resolveGmComponent mums c@GmComponent {..} = do
@@ -298,42 +301,18 @@ resolveGmComponent mums c@GmComponent {..} = do
            [ "-optP-include", "-optP" ++ macrosHeaderPath ]
         ]
 
-resolveEntrypoint :: IOish m
+resolveEntrypoint :: (IOish m, GmLog m)
     => Cradle
     -> GmComponent GMCRaw ChEntrypoint
     -> m (GmComponent GMCRaw (Set ModulePath))
-resolveEntrypoint Cradle {..} c@GmComponent {..} =
+resolveEntrypoint Cradle {..} c@GmComponent {..} = do
     withLightHscEnv gmcGhcSrcOpts $ \env -> do
       let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
       eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
       rms <- resolveModule env srcDirs `mapM` eps
       return c { gmcEntrypoints = Set.fromList $ catMaybes rms }
 
-resolveModule :: MonadIO m =>
+resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]
-    HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath)
-resolveModule env _srcDirs (Right mn) =
-    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
-resolveModule env srcDirs (Left fn') = liftIO $ do
-    mfn <- findFile' srcDirs fn'
-    case mfn of
-      Nothing -> return Nothing
-      Just fn'' -> do
-          fn <- canonicalizePath fn''
-          emn <- fileModuleName env fn
-          return $ case emn of
-              Left _ -> Nothing -- TODO: should expose these errors otherwise
-                                -- modules with preprocessor/parse errors are
-                                -- going to be missing
-              Right mmn -> Just $
-                  case mmn of
-                    Nothing -> mkMainModulePath fn
-                    Just mn -> ModulePath mn fn
- where
-   findFile' dirs file =
-       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs
-
-resolveChEntrypoints ::
-  FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName]
 resolveChEntrypoints _ (ChLibEntrypoint em om) =
     return $ map (Right . chModToMod) (em ++ om)
 
@@ -351,8 +330,40 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do
 chModToMod :: ChModuleName -> ModuleName
 chModToMod (ChModuleName mn) = mkModuleName mn
 
-resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) =>
+resolveModule :: (MonadIO m, GmLog m) =>
-    Maybe [Either FilePath ModuleName]
+  HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
+resolveModule env _srcDirs (Right mn) =
+    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
+resolveModule env srcDirs (Left fn') = do
+    mfn <-  liftIO $ findFile' srcDirs fn'
+    case mfn of
+      Nothing -> return Nothing
+      Just fn'' -> do
+          fn <-  liftIO $ canonicalizePath fn''
+          emn <-  liftIO $ fileModuleName env fn
+          case emn of
+              Left errs -> do
+                gmLog GmWarning ("resolveModule " ++ show fn) $
+                  empty $+$ (vcat $ map text errs)
+                return Nothing -- TODO: should expose these errors otherwise
+                               -- modules with preprocessor/parse errors are
+                               -- going to be missing
+              Right mmn -> return $ Just $
+                  case mmn of
+                    Nothing -> mkMainModulePath fn
+                    Just mn -> ModulePath mn fn
+ where
+   -- needed for ghc 7.4
+   findFile' dirs file =
+       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs
+
+   -- fileModuleName fn (dir:dirs)
+   --     | makeRelative dir fn /= fn
+
+type CompilationUnit = Either FilePath ModuleName
+
+resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
+    => Maybe [CompilationUnit]
         -- ^ Updated modules
     -> [GmComponent GMCRaw (Set ModulePath)]
     -> m (Map ChComponentName (GmComponent GMCResolved (Set ModulePath)))

test/TargetSpec.hs

@@ -10,6 +10,8 @@ import TestUtils
 import GHC
 import Data.List
 import Data.Maybe
+import System.Directory
+import System.FilePath
 
 spec :: Spec
 spec = do
@@ -33,3 +35,13 @@ spec = do
                 mdl <- findModule "Data.List" Nothing
                 mmi <- getModuleInfo mdl
                 liftIO $ isJust mmi `shouldBe` True
+
+
+    describe "resolveModule" $ do
+        it "Works when a module given as path uses CPP" $ do
+            dir <- getCurrentDirectory
+            print dir
+            let srcDirs = [dir </> "test/data/target/src"]
+            withLightHscEnv [] $ \env -> runNullLog $ do
+                Just _ <- resolveModule env srcDirs (Left $ dir </> "test/data/target/src/A/B/C/D/E.hs")
+                return ()