@@ -18,6 +18,8 @@ import Control.Monad (filterM, unless, void)
1818import Control.Monad.Except (runExceptT, throwError)
1919import Control.Monad.IO.Class (liftIO)
2020import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
2123import Data.Coerce (coerce)
2224import Data.Default (def)
2325import Data.Either (partitionEithers)
@@ -435,7 +437,7 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do
435437 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
436438 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
437439 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
438− pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)
440+ pure (canonicalPkgFile `relativeTo` canonicalPathBase, (`relativeTo` canonicalPathBase) <$> canonicalSrcDirs)
439441
440442 pure
441443 $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
@@ -504,3 +506,29 @@ pathToTree a p = go $ splitDirectories p
504506 where
505507 go [] = PathTree_Node (Just a) mempty
506508 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
509+
510+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
511+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
512+zipDefaultWith _da _db _f [] [] = []
513+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
514+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
515+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
516+
517+-- | Makes the first absolute path relative to the second absolute path.
518+--
519+-- Both input paths MUST be absolute.
520+--
521+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
522+-- enough @..@ paths to make the resulting path truly relative in virtually every
523+-- case. The only exception is on Windows when the two paths are on different
524+-- drives. In this case the resulting path may be absolute.
525+relativeTo :: FilePath -> FilePath -> FilePath
526+relativeTo dir base
527+ = bifoldr1 (</>)
528+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
529+ $ unzip
530+ $ dropWhile (\(a,b) -> a == b)
531+ $ zipDefaultWith Nothing Nothing (,)
532+ (map Just $ splitDirectories base)
533+ (map Just $ splitDirectories dir)
534+ where collapse = foldr (</>) ""