From 6f59f07f00314d51cd8a6804ce09617b4326b4bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 11 Apr 2015 16:41:17 +0200 Subject: [PATCH] Fix non canonicalized paths --- Language/Haskell/GhcMod/HomeModuleGraph.hs | 33 +++++++++++++--------- Language/Haskell/GhcMod/Target.hs | 13 +++++---- Language/Haskell/GhcMod/Types.hs | 12 +++----- 3 files changed, 31 insertions(+), 27 deletions(-) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 09bfc08..f42c6db 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -24,13 +24,16 @@ module Language.Haskell.GhcMod.HomeModuleGraph ( , findModulePath , findModulePathSet , fileModuleName + , canonicalizeModulePath , homeModuleGraph , updateHomeModuleGraph + , canonicalizeModuleGraph , reachable , moduleGraphToDot ) where import DriverPipeline +import DynFlags import ErrUtils import Exception import Finder @@ -45,14 +48,17 @@ import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid +import Data.Traversable as T (mapM) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath +import System.Directory import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Gap (parseModuleHeader) @@ -111,12 +117,8 @@ reachable smp0 GmModuleGraph {..} = go smp0 pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph pruneUnreachable smp0 gmg@GmModuleGraph {..} = let r = reachable smp0 gmg - rfn = Set.map mpPath r - rmn = Set.map mpModule r in GmModuleGraph { - gmgFileMap = Map.filterWithKey (\k _ -> k `Set.member` rfn) gmgFileMap, - gmgModuleMap = Map.filterWithKey (\k _ -> k `Set.member` rmn) gmgModuleMap, gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph } @@ -143,29 +145,37 @@ find env mn = liftIO $ do res <- findHomeModule env mn case res of -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc - Found loc@ModLocation { ml_hs_file = Just _ } _mod -> do + Found loc@ModLocation { ml_hs_file = Just _ } _mod -> return $ normalise <$> ml_hs_file loc _ -> return Nothing + +canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp + +canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph +canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do + GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) + where + fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) + + updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m) => HscEnv -> GmModuleGraph -> Set ModulePath -- ^ Initial set of modules -> Set ModulePath -- ^ Updated set of modules -> m GmModuleGraph -updateHomeModuleGraph env GmModuleGraph {..} smp usmp = do +updateHomeModuleGraph env GmModuleGraph {..} smp sump = do -- TODO: It would be good if we could retain information about modules that -- stop to compile after we've already successfully parsed them at some -- point. Figure out a way to delete the modules about to be updated only -- after we're sure they won't fail to parse .. or something. Should probably -- push this whole prune logic deep into updateHomeModuleGraph' - (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env usmp) + (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) where runS = flip execStateT defaultS { sGraph = graph' } graph' = GmModuleGraph { - gmgFileMap = Set.foldr (Map.delete . mpPath) gmgFileMap usmp, - gmgModuleMap = Set.foldr (Map.delete . mpModule) gmgModuleMap usmp, - gmgGraph = Set.foldr Map.delete gmgGraph usmp + gmgGraph = Set.foldr Map.delete gmgGraph sump } mkFileMap :: Set ModulePath -> Map FilePath ModulePath @@ -181,7 +191,6 @@ updateHomeModuleGraph' -> m () updateHomeModuleGraph' env smp0 = do go `mapM_` Set.toList smp0 - where go :: ModulePath -> m () go mp = do @@ -192,8 +201,6 @@ updateHomeModuleGraph' env smp0 = do smp <- collapseMaybeSet `liftM` step mp graphUnion GmModuleGraph { - gmgFileMap = mkFileMap smp, - gmgModuleMap = mkModuleMap smp, gmgGraph = Map.singleton mp smp } diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 3a7c78d..6231683 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -142,15 +142,15 @@ runGmlTWith efnmns' mdf wrapper action = do let (fns, mns) = partitionEithers efnmns' ccfns = map (cradleCurrentDir crdl ) fns cfns <- liftIO $ mapM canonicalizePath ccfns - let rfns = map (makeRelative $ cradleRootDir crdl) cfns - serfnmn = Set.fromList $ map Right mns ++ map Left rfns - + let serfnmn = Set.fromList $ map Right mns ++ map Left cfns opts <- targetGhcOptions crdl serfnmn let opts' = opts ++ ghcUserOptions initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf + let rfns = map (makeRelative $ cradleRootDir crdl) cfns + unGmlT $ wrapper $ do loadTargets (map moduleNameString mns ++ rfns) action @@ -268,7 +268,7 @@ resolveGmComponent mums c@GmComponent {..} = do Nothing -> return simp Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums - mg' <- updateHomeModuleGraph env mg simp sump + mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } @@ -285,13 +285,14 @@ resolveEntrypoint Cradle {..} c@GmComponent {..} = resolveModule :: MonadIO m => HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath) -resolveModule env _srcDirs (Right mn) = liftIO $ findModulePath env mn +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 - let fn = normalise fn'' + fn <- canonicalizePath fn'' emn <- fileModuleName env fn return $ case emn of Left _ -> Nothing diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 6430b6b..fcc0199 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -177,8 +177,6 @@ data GmLogLevel = GmPanic type PkgDb = (Map Package PackageConfig) data GmModuleGraph = GmModuleGraph { - gmgFileMap :: Map FilePath ModulePath, - gmgModuleMap :: Map ModuleName ModulePath, gmgGraph :: Map ModulePath (Set ModulePath) } deriving (Eq, Ord, Show, Read, Generic, Typeable) @@ -204,14 +202,12 @@ instance Serialize GmModuleGraph where intToMp i = fromJust $ Map.lookup i impm mpGraph :: Map ModulePath (Set ModulePath) mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph - mpFm = Map.fromList $ map (mpPath &&& id) $ Map.keys mpim - mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim - return $ GmModuleGraph mpFm mpMn mpGraph + return $ GmModuleGraph mpGraph instance Monoid GmModuleGraph where - mempty = GmModuleGraph mempty mempty mempty - mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') = - GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c') + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') data GmComponentType = GMCRaw | GMCResolved