Fix non canonicalized paths

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,
+       gmgGraph = Set.foldr Map.delete gmgGraph sump
-       gmgModuleMap = Set.foldr (Map.delete . mpModule) gmgModuleMap usmp,
-       gmgGraph = Set.foldr Map.delete gmgGraph usmp
     }
 
 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
             }
 

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
+    let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
-        serfnmn = Set.fromList $ map Right mns ++ map Left rfns
-
     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

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
+     return $ GmModuleGraph mpGraph
-         mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim
-     return $ GmModuleGraph mpFm mpMn mpGraph
 
 instance Monoid GmModuleGraph where
-    mempty  = GmModuleGraph mempty mempty mempty
+    mempty  = GmModuleGraph mempty
-    mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') =
+    mappend (GmModuleGraph a) (GmModuleGraph a') =
-        GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
+        GmModuleGraph (Map.unionWith Set.union a a')
 
 data GmComponentType = GMCRaw
                      | GMCResolved