diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 7aafc16..3b382a0 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/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 - env' = env { hsc_dflags = setDf (hsc_dflags env) } - in preprocess env' (fn, Nothing) + ep <- preprocessFile env fn 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 - -> FilePath - -> IO (Either ErrorMessages (Maybe ModuleName)) +preprocessFile :: MonadIO m => + HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) +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 - case parseModuleHeader src (hsc_dflags env) fn of - Left errs -> return (Left errs) - Right (_, lmdl) -> do - let HsModule {..} = unLoc lmdl - return $ Right $ unLoc <$> hsmodName + ep <- preprocessFile env fn + case ep of + Left errs -> do + return $ Left errs + Right (_warns, (dflags, procdFile)) -> do + 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 diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 8778d33..2d97580 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/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'. diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index e8c35bf..a952840 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/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 => - 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 :: FilePath -> ChEntrypoint -> IO [CompilationUnit] 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) => - Maybe [Either FilePath ModuleName] +resolveModule :: (MonadIO m, GmLog m) => + 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))) diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index 8429621..e75807c 100644 --- a/test/TargetSpec.hs +++ b/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 ()