@@ -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)
@@ -74,7 +76,7 @@ import Obelisk.CliApp (
7476 withSpinner,
7577 )
7678import Obelisk.Command.Nix
77−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
79+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
7880import Obelisk.Command.Thunk (attrCacheFileName)
7981import Obelisk.Command.Utils (findExePath, ghcidExePath)
8082
@@ -162,11 +164,12 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
162164run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163165run root interpretPaths = do
164166 pkgs <- getParsedLocalPkgs root interpretPaths
165− withGhciScript pkgs root $ \dotGhciPath -> do
166− freePort <- getFreePort
167+ withGhciScript pkgs $ \dotGhciPath -> do
167168 assets <- findProjectAssets root
168169 putLog Debug $ "Assets impurely loaded from: " <> assets
169− runGhcid root True dotGhciPath pkgs $ Just $ unwords
170+ ghciArgs <- getGhciSessionSettings pkgs root
171+ freePort <- getFreePort
172+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
170173 [ "Obelisk.Run.run"
171174 , show freePort
172175 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -177,14 +180,16 @@ run root interpretPaths = do
177180runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
178181runRepl root interpretPaths = do
179182 pkgs <- getParsedLocalPkgs root interpretPaths
180− withGhciScript pkgs "." $ \dotGhciPath ->
181− runGhciRepl root pkgs dotGhciPath
183+ ghciArgs <- getGhciSessionSettings pkgs "."
184+ withGhciScript pkgs $ \dotGhciPath ->
185+ runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
182186
183187runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
184188runWatch root interpretPaths = do
185189 pkgs <- getParsedLocalPkgs root interpretPaths
186− withGhciScript pkgs root $ \dotGhciPath ->
187− runGhcid root True dotGhciPath pkgs Nothing
190+ ghciArgs <- getGhciSessionSettings pkgs root
191+ withGhciScript pkgs $ \dotGhciPath ->
192+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
188193
189194exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
190195exportGhciConfig root interpretPaths = do
@@ -194,7 +199,7 @@ exportGhciConfig root interpretPaths = do
194199nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
195200nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
196201 pkgs <- getParsedLocalPkgs root interpretPaths
197− nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
202+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
198203
199204-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
200205getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
@@ -395,12 +400,14 @@ packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&&
395400withGhciScript
396401 :: (MonadObelisk m, Foldable f)
397402 => f CabalPackageInfo -- ^ List of packages to load into ghci
398− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
399403 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
400404 -> m ()
401−withGhciScript (toList -> packageInfos) pathBase f = do
402− ghciSettings <- getGhciSessionSettings packageInfos pathBase
403− let
405+withGhciScript (toList -> packageInfos) f =
406+ withSystemTempDirectory "ob-ghci" $ \fp -> do
407+ let dotGhciPath = fp </> ".ghci"
408+ liftIO $ writeFile dotGhciPath dotGhci
409+ f dotGhciPath
410+ where
404411 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
405412 modulesToLoad = mconcat
406413 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
@@ -408,22 +415,18 @@ withGhciScript (toList -> packageInfos) pathBase f = do
408415 , [ "Frontend" | "frontend" `Set.member` packageNames ]
409416 ]
410417 dotGhci = unlines
411− [ ":set " <> unwords ghciSettings -- TODO: Shell escape
412− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
418+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
413419 , "import qualified Obelisk.Run"
414420 , "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
421+ , "import qualified Backend"
422+ ]
420423
421424-- | Builds a list of options to pass to ghci or set in .ghci file that configures
422425-- the preprocessor and source includes.
423426getGhciSessionSettings
424427 :: (MonadObelisk m, Foldable f)
425428 => f CabalPackageInfo -- ^ List of packages to load into ghci
426− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
429+ -> FilePath -- ^ All paths will be relative to this path
427430 -> m [String]
428431getGhciSessionSettings (toList -> packageInfos) pathBase = do
429432 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
@@ -435,57 +438,62 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do
435438 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
436439 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
437440 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
438− pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)
441+ pure (canonicalPkgFile `relativeTo` canonicalPathBase, (`relativeTo` canonicalPathBase) <$> canonicalSrcDirs)
439442
440443 pure
441− $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
444+ $ baseGhciOptions
445+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
442446 <> concatMap (\p -> ["-optF", p]) pkgFiles
443447 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
444448
449+baseGhciOptions :: [String]
450+baseGhciOptions =
451+ [ "-ignore-dot-ghci"
452+ , "-no-user-package-db"
453+ , "-package-env", "-"
454+ ]
455+
445456-- | Run ghci repl
446457runGhciRepl
447458 :: (MonadObelisk m, Foldable f)
448459 => FilePath -- ^ Path to project root
449− -> f CabalPackageInfo
450− -> FilePath -- ^ Path to .ghci
460+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
461+ -> [String] -- ^ GHCi arguments
451462 -> m ()
452−runGhciRepl root (toList -> packages) dotGhci =
463+runGhciRepl root (toList -> packages) ghciArgs =
453464 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
454465 -- 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
466+ nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
467+ Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
456468
457469-- | Run ghcid
458470runGhcid
459471 :: (MonadObelisk m, Foldable f)
460472 => FilePath -- ^ Path to project root
461473 -> Bool -- ^ Should we chdir to root when running this process?
462− -> FilePath -- ^ Path to .ghci
463− -> f CabalPackageInfo
474+ -> [String] -- ^ GHCi arguments
475+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
464476 -> Maybe String -- ^ Optional command to run at every reload
465477 -> m ()
466−runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
467− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
478+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
479+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
480+ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
468481 where
469482 opts =
470483 [ "-W"
471− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
472484 , "--outputfile=ghcid-output.txt"
473485 ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
474486 <> map (\x -> "--restart='" <> x <> "'") restartFiles
475487 <> testCmd
488+ <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
476489 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
477490
478491 adjustRoot x = if chdirToRoot then makeRelative root x else x
479492 reloadFiles = map adjustRoot [root </> "config"]
480493 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
481494
482−makeBaseGhciOptions :: FilePath -> String
483−makeBaseGhciOptions dotGhci =
484− unwords
485− [ "-no-user-package-db"
486− , "-package-env -"
487− , "-ghci-script " <> dotGhci
488− ]
495+mkGhciScriptArg :: FilePath -> [String]
496+mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
489497
490498getFreePort :: MonadIO m => m PortNumber
491499getFreePort = liftIO $ withSocketsDo $ do
@@ -504,3 +512,29 @@ pathToTree a p = go $ splitDirectories p
504512 where
505513 go [] = PathTree_Node (Just a) mempty
506514 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
515+
516+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
517+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
518+zipDefaultWith _da _db _f [] [] = []
519+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
520+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
521+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
522+
523+-- | Makes the first absolute path relative to the second absolute path.
524+--
525+-- Both input paths MUST be absolute.
526+--
527+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
528+-- enough @..@ paths to make the resulting path truly relative in virtually every
529+-- case. The only exception is on Windows when the two paths are on different
530+-- drives. In this case the resulting path may be absolute.
531+relativeTo :: FilePath -> FilePath -> FilePath
532+relativeTo dir base
533+ = bifoldr1 (</>)
534+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
535+ $ unzip
536+ $ dropWhile (\(a,b) -> a == b)
537+ $ zipDefaultWith Nothing Nothing (,)
538+ (map Just $ splitDirectories base)
539+ (map Just $ splitDirectories dir)
540+ where collapse = foldr (</>) ""