@@ -14,21 +14,25 @@ module Obelisk.Command.Run where
1414import Control.Arrow ((&&&))
1515import Control.Exception (Exception, bracket)
1616import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
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)
2426import Data.Foldable (fold, for_, toList)
2527import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
2629import Data.List.NonEmpty (NonEmpty)
2730import qualified Data.List.NonEmpty as NE
2831import Data.Map (Map)
2932import qualified Data.Map as Map
3033import qualified Data.Map.Monoidal as MMap
31−import Data.Maybe
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
3236import Data.Set (Set)
3337import qualified Data.Set as Set
3438import Data.String.Here.Interpolated (i)
@@ -42,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
4246import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4347import Distribution.Parsec.ParseResult (runParseResult)
4448import qualified Distribution.System as Dist
45−import Distribution.Types.BuildInfo
46−import Distribution.Types.CondTree
47−import Distribution.Types.GenericPackageDescription
48−import Distribution.Types.Library
49−import Distribution.Utils.Generic
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
50+import Distribution.Types.CondTree (simplifyCondTree)
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
52+import Distribution.Types.Library (libBuildInfo)
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
5054import qualified Distribution.Parsec.Common as Dist
5155import qualified Hpack.Config as Hpack
5256import qualified Hpack.Render as Hpack
5357import qualified Hpack.Yaml as Hpack
54−import Language.Haskell.Extension
55−import Network.Socket hiding (Debug)
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
5660import System.Directory
5761import System.Environment (getExecutablePath)
5862import System.FilePath
@@ -62,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
6266import Obelisk.App (MonadObelisk)
6367import Obelisk.CliApp (
6468 Severity (..),
65− createProcess_,
6669 failWith,
6770 proc,
6871 putLog,
6972 readCreateProcessWithExitCode,
7073 readProcessAndLogStderr,
74+ runProcess_,
7175 setCwd,
7276 setDelegateCtlc,
73− waitForProcess,
7477 withSpinner,
7578 )
7679import Obelisk.Command.Nix
77−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
7881import Obelisk.Command.Thunk (attrCacheFileName)
7982import Obelisk.Command.Utils (findExePath, ghcidExePath)
8083
@@ -91,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
9194 -- ^ List of globally set languages of the library component
9295 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9396 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
97+ , _cabalPackageInfo_cppOptions :: [String]
98+ -- ^ List of CPP (C Preprocessor) options (e.g. the "cpp-options" field of the cabal file)
9499 }
95100
96−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
97102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
98103
99104textInterpret :: Interpret -> Text
@@ -107,9 +112,6 @@ data PathTree a = PathTree_Node
107112 (Map FilePath (PathTree a)) -- Branches to deeper leaves
108113 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
109114
110−emptyPathTree :: PathTree a
111−emptyPathTree = PathTree_Node Nothing mempty
112−
113115-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
114116drawPathTree :: (a -> Text) -> PathTree a -> Text
115117drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -149,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
149151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
150152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
151153 freePort <- getFreePort
152− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
154+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
153155 [ show freePort
154156 , T.unpack assets
155157 , profileBaseName
@@ -157,16 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
157159 , "-po" <> profileBaseName
158160 ] <> rtsFlags
159161 <> [ "-RTS" ]
160− void $ waitForProcess ph
161162
162163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163164run root interpretPaths = do
164165 pkgs <- getParsedLocalPkgs root interpretPaths
165− withGhciScript pkgs root $ \dotGhciPath -> do
166− freePort <- getFreePort
167− assets <- findProjectAssets root
168− putLog Debug $ "Assets impurely loaded from: " <> assets
169− runGhcid root True dotGhciPath pkgs $ Just $ unwords
166+ assets <- findProjectAssets root
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ ghciArgs <- getGhciSessionSettings pkgs root True
169+ freePort <- getFreePort
170+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
170172 [ "Obelisk.Run.run"
171173 , show freePort
172174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -177,24 +179,26 @@ run root interpretPaths = do
177179runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
178180runRepl root interpretPaths = do
179181 pkgs <- getParsedLocalPkgs root interpretPaths
180− withGhciScript pkgs "." $ \dotGhciPath ->
181− runGhciRepl root pkgs dotGhciPath
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
182185
183186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
184187runWatch root interpretPaths = do
185188 pkgs <- getParsedLocalPkgs root interpretPaths
186− withGhciScript pkgs root $ \dotGhciPath ->
187− runGhcid root True dotGhciPath pkgs Nothing
189+ ghciArgs <- getGhciSessionSettings pkgs root True
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
188192
189−exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
190−exportGhciConfig root interpretPaths = do
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194+exportGhciConfig useRelativePaths root interpretPaths = do
191195 pkgs <- getParsedLocalPkgs root interpretPaths
192− getGhciSessionSettings pkgs "."
196+ getGhciSessionSettings pkgs "." useRelativePaths
193197
194198nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
195199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
196200 pkgs <- getParsedLocalPkgs root interpretPaths
197− nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
201+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
198202
199203-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
200204getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
@@ -300,15 +304,16 @@ parseCabalPackage
300304 -> m (Maybe CabalPackageInfo)
301305parseCabalPackage dir = parseCabalPackage' dir >>= \case
302306 Left err -> Nothing <$ putLog Error err
303− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
304308 for_ warnings $ putLog Warning . T.pack . show
305309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
306311
307312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
308313parseCabalPackage'
309314 :: (MonadIO m)
310315 => FilePath -- ^ Package directory
311− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
312317parseCabalPackage' pkg = runExceptT $ do
313318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
314319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -336,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
336341 case condLibrary <$> result of
337342 Right (Just condLib) -> do
338343 let (_, lib) = simplifyCondTree evalConfVar condLib
339− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
340345 { _cabalPackageInfo_packageName = T.pack packageName
341346 , _cabalPackageInfo_packageFile = packageFile
342347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -348,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
348353 , _cabalPackageInfo_defaultLanguage =
349354 defaultLanguage $ libBuildInfo lib
350355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
351357 }
352− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
353359 Left (_, errors) ->
354360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
355361
356362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
357363parsePackagesOrFail dirs' = do
358− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
359365 flip fmap (parseCabalPackage dir) $ \case
360366 Just packageInfo
361− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
362− _ -> Left dir
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
363369
364370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
365371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -381,9 +387,6 @@ parsePackagesOrFail dirs' = do
381387 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
382388 Just xs -> pure xs
383389
384− unless (null pkgDirErrs) $
385− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
386−
387390 pure packageInfos
388391 where
389392 dirs = toList dirs'
@@ -391,41 +394,57 @@ parsePackagesOrFail dirs' = do
391394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
392395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
393396
397+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
398+withGhciScriptArgs
399+ :: (MonadObelisk m, Foldable f)
400+ => f CabalPackageInfo -- ^ List of packages to load into ghci
401+ -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
402+ -> m ()
403+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
404+ where
405+ -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
406+ -- is passed to the ghci session.
407+ loadPreludeManually =
408+ [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
409+ , ":set -XImplicitPrelude" -- Turn the default setting on
410+ ]
411+
394412-- | Create ghci configuration to load the given packages
395413withGhciScript
396414 :: (MonadObelisk m, Foldable f)
397− => f CabalPackageInfo -- ^ List of packages to load into ghci
398− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
415+ => [String] -- ^ Commands to prefix to file
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
399417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
400418 -> m ()
401−withGhciScript (toList -> packageInfos) pathBase f = do
402− ghciSettings <- getGhciSessionSettings packageInfos pathBase
403− let
419+withGhciScript preCommands (toList -> packageInfos) f =
420+ withSystemTempDirectory "ob-ghci" $ \fp -> do
421+ let dotGhciPath = fp </> ".ghci"
422+ liftIO $ writeFile dotGhciPath dotGhci
423+ f dotGhciPath
424+ where
404425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
405426 modulesToLoad = mconcat
406427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
407428 , [ "Backend" | "backend" `Set.member` packageNames ]
408429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
409430 ]
410− dotGhci = unlines
411− [ ":set " <> unwords ghciSettings -- TODO: Shell escape
412− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
431+ dotGhci = unlines $
432+ preCommands <>
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
413434 , "import qualified Obelisk.Run"
414435 , "import qualified Frontend"
415− , "import qualified Backend" ]
416− withSystemTempDirectory "ob-ghci" $ \fp -> do
417− let dotGhciPath = fp </> ".ghci"
418− liftIO $ writeFile dotGhciPath dotGhci
419− f dotGhciPath
436+ , "import qualified Backend"
437+ ]
420438
421439-- | Builds a list of options to pass to ghci or set in .ghci file that configures
422440-- the preprocessor and source includes.
423441getGhciSessionSettings
424442 :: (MonadObelisk m, Foldable f)
425443 => f CabalPackageInfo -- ^ List of packages to load into ghci
426− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
444+ -> FilePath -- ^ All paths will be relative to this path
445+ -> Bool -- ^ Use relative paths
427446 -> m [String]
428−getGhciSessionSettings (toList -> packageInfos) pathBase = do
447+getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
429448 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
430449 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
431450 -- all paths to 'pathBase'.
@@ -435,66 +454,69 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do
435454 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
436455 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
437456 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
438− pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)
457+ pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
439458
440459 pure
441− $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
460+ $ baseGhciOptions
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
442462 <> concatMap (\p -> ["-optF", p]) pkgFiles
443463 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
464+ where
465+ relativeTo' = if useRelativePaths then relativeTo else const
466+
467+baseGhciOptions :: [String]
468+baseGhciOptions =
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
472+ ]
444473
445474-- | Run ghci repl
446475runGhciRepl
447476 :: (MonadObelisk m, Foldable f)
448477 => FilePath -- ^ Path to project root
449− -> f CabalPackageInfo
450− -> FilePath -- ^ Path to .ghci
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
479+ -> [String] -- ^ GHCi arguments
451480 -> m ()
452−runGhciRepl root (toList -> packages) dotGhci =
481+runGhciRepl root (toList -> packages) ghciArgs =
453482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
454483 -- ghc that is provided by the shell in the user's project.
455− nixShellWithPkgs root True False (packageInfoToNamePathMap packages) "ghc" $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
484+ nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
456486
457487-- | Run ghcid
458488runGhcid
459489 :: (MonadObelisk m, Foldable f)
460490 => FilePath -- ^ Path to project root
461491 -> Bool -- ^ Should we chdir to root when running this process?
462− -> FilePath -- ^ Path to .ghci
463− -> f CabalPackageInfo
492+ -> [String] -- ^ GHCi arguments
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
464494 -> Maybe String -- ^ Optional command to run at every reload
465495 -> m ()
466−runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
467− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
468499 where
469− opts =
470− [ "-W"
471− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
472− , "--outputfile=ghcid-output.txt"
473− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
474− <> map (\x -> "--restart='" <> x <> "'") restartFiles
475− <> testCmd
476− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
477−
500+ opts = concat
501+ [ ["-W"]
502+ , ["--outputfile=ghcid-output.txt"]
503+ , map (\x -> "--reload=" <> x) reloadFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
507+ ]
478508 adjustRoot x = if chdirToRoot then makeRelative root x else x
479509 reloadFiles = map adjustRoot [root </> "config"]
480510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
481511
482−makeBaseGhciOptions :: FilePath -> String
483−makeBaseGhciOptions dotGhci =
484− unwords
485− [ "-no-user-package-db"
486− , "-package-env -"
487− , "-ghci-script " <> dotGhci
488− ]
489−
490−getFreePort :: MonadIO m => m PortNumber
491−getFreePort = liftIO $ withSocketsDo $ do
492− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
493− bracket (open addr) close socketPort
512+getFreePort :: MonadIO m => m Socket.PortNumber
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
515+ bracket (open addr) Socket.close Socket.socketPort
494516 where
495517 open addr = do
496− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
497− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
498520 return sock
499521
500522
@@ -504,3 +526,29 @@ pathToTree a p = go $ splitDirectories p
504526 where
505527 go [] = PathTree_Node (Just a) mempty
506528 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
529+
530+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
531+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
532+zipDefaultWith _da _db _f [] [] = []
533+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
534+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
535+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
536+
537+-- | Makes the first absolute path relative to the second absolute path.
538+--
539+-- Both input paths MUST be absolute.
540+--
541+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
542+-- enough @..@ paths to make the resulting path truly relative in virtually every
543+-- case. The only exception is on Windows when the two paths are on different
544+-- drives. In this case the resulting path may be absolute.
545+relativeTo :: FilePath -> FilePath -> FilePath
546+relativeTo dir base
547+ = bifoldr1 (</>)
548+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
549+ $ unzip
550+ $ dropWhile (\(a,b) -> a == b)
551+ $ zipDefaultWith Nothing Nothing (,)
552+ (map Just $ splitDirectories base)
553+ (map Just $ splitDirectories dir)
554+ where collapse = foldr (</>) ""