@@ -14,25 +14,20 @@ module Obelisk.Command.Run where
1414import Control.Arrow ((&&&))
1515import Control.Exception (Exception, bracket)
1616import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM)
17+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)
2321import Data.Coerce (coerce)
2422import Data.Default (def)
2523import Data.Either (partitionEithers)
2624import Data.Foldable (fold, for_, toList)
2725import Data.Functor.Identity (runIdentity)
28−import Data.List (intercalate)
2926import Data.List.NonEmpty (NonEmpty)
3027import qualified Data.List.NonEmpty as NE
3128import Data.Map (Map)
3229import qualified Data.Map as Map
33−import qualified Data.Map.Monoidal as MMap
34−import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35−import Data.Ord (comparing)
30+import Data.Maybe
3631import Data.Set (Set)
3732import qualified Data.Set as Set
3833import Data.String.Here.Interpolated (i)
@@ -46,17 +41,17 @@ import Distribution.Compiler (CompilerFlavor(..))
4641import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4742import Distribution.Parsec.ParseResult (runParseResult)
4843import qualified Distribution.System as Dist
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)
44+import Distribution.Types.BuildInfo
45+import Distribution.Types.CondTree
46+import Distribution.Types.GenericPackageDescription
47+import Distribution.Types.Library
48+import Distribution.Utils.Generic
5449import qualified Distribution.Parsec.Common as Dist
5550import qualified Hpack.Config as Hpack
5651import qualified Hpack.Render as Hpack
5752import qualified Hpack.Yaml as Hpack
58−import Language.Haskell.Extension (Extension, Language)
59−import qualified Network.Socket as Socket
53+import Language.Haskell.Extension
54+import Network.Socket hiding (Debug)
6055import System.Directory
6156import System.Environment (getExecutablePath)
6257import System.FilePath
@@ -66,18 +61,19 @@ import System.IO.Temp (withSystemTempDirectory)
6661import Obelisk.App (MonadObelisk)
6762import Obelisk.CliApp (
6863 Severity (..),
64+ createProcess_,
6965 failWith,
7066 proc,
7167 putLog,
7268 readCreateProcessWithExitCode,
7369 readProcessAndLogStderr,
74− runProcess_,
7570 setCwd,
7671 setDelegateCtlc,
72+ waitForProcess,
7773 withSpinner,
7874 )
7975import Obelisk.Command.Nix
80−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
76+import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
8177import Obelisk.Command.Thunk (attrCacheFileName)
8278import Obelisk.Command.Utils (findExePath, ghcidExePath)
8379
@@ -94,11 +90,9 @@ data CabalPackageInfo = CabalPackageInfo
9490 -- ^ List of globally set languages of the library component
9591 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9692 -- ^ 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)
9993 }
10094
101−-- | 'Bool' with a better name for its purpose.
95+-- | 'Bool' with a better name for it's purpose.
10296data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
10397
10498textInterpret :: Interpret -> Text
@@ -112,6 +106,9 @@ data PathTree a = PathTree_Node
112106 (Map FilePath (PathTree a)) -- Branches to deeper leaves
113107 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
114108
109+emptyPathTree :: PathTree a
110+emptyPathTree = PathTree_Node Nothing mempty
111+
115112-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116113drawPathTree :: (a -> Text) -> PathTree a -> Text
117114drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -151,7 +148,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151148 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152149 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153150 freePort <- getFreePort
154− runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
151+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155152 [ show freePort
156153 , T.unpack assets
157154 , profileBaseName
@@ -159,16 +156,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159156 , "-po" <> profileBaseName
160157 ] <> rtsFlags
161158 <> [ "-RTS" ]
159+ void $ waitForProcess ph
162160
163161run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164162run root interpretPaths = do
165163 pkgs <- getParsedLocalPkgs root interpretPaths
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
164+ withGhciScript pkgs root $ \dotGhciPath -> do
165+ freePort <- getFreePort
166+ assets <- findProjectAssets root
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ runGhcid root True dotGhciPath pkgs $ Just $ unwords
172169 [ "Obelisk.Run.run"
173170 , show freePort
174171 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -179,26 +176,24 @@ run root interpretPaths = do
179176runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180177runRepl root interpretPaths = do
181178 pkgs <- getParsedLocalPkgs root interpretPaths
182− ghciArgs <- getGhciSessionSettings pkgs "." True
183− withGhciScriptArgs pkgs $ \dotGhciArgs ->
184− runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
179+ withGhciScript pkgs "." $ \dotGhciPath ->
180+ runGhciRepl root pkgs dotGhciPath
185181
186182runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187183runWatch root interpretPaths = do
188184 pkgs <- getParsedLocalPkgs root interpretPaths
189− ghciArgs <- getGhciSessionSettings pkgs root True
190− withGhciScriptArgs pkgs $ \dotGhciArgs ->
191− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
185+ withGhciScript pkgs root $ \dotGhciPath ->
186+ runGhcid root True dotGhciPath pkgs Nothing
192187
193−exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194−exportGhciConfig useRelativePaths root interpretPaths = do
188+exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
189+exportGhciConfig root interpretPaths = do
195190 pkgs <- getParsedLocalPkgs root interpretPaths
196− getGhciSessionSettings pkgs "." useRelativePaths
191+ getGhciSessionSettings pkgs "."
197192
198193nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
199194nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200195 pkgs <- getParsedLocalPkgs root interpretPaths
201− nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
196+ nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
202197
203198-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
204199getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
@@ -216,12 +211,11 @@ getLocalPkgs root interpretPaths = do
216211
217212 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
218213 -- obelisk project is our own.
219− obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
220− filter (/= root) $ map takeDirectory obeliskPackagePaths
214+ obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $ filter (/= root) $ map takeDirectory obeliskPackagePaths
221215 putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
222216 let rootsAndExclusions = calcIntepretFinds "" interpretPaths
223217
224− fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
218+ fmap fold $ for (Map.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
225219 let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
226220 in fmap (Set.fromList . map normalise) $ runFind $
227221 ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
@@ -235,14 +229,14 @@ getLocalPkgs root interpretPaths = do
235229-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
236230-- This is used when constructing a set of @find@ commands to run to produce a set of packages
237231-- that matches the user's @--interpret@/@--no-interpret@ settings.
238−calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
232+calcIntepretFinds :: FilePath -> PathTree Interpret -> Map FilePath (Set FilePath)
239233calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
240234 where
241235 go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
242236 exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
243237 pure $ Map.singleton parent' children'
244− deeperFinds <- Map.traverseWithKey go exclusions
245− pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
238+ deeperFinds <- fmap fold $ Map.traverseWithKey go exclusions
239+ pure $ Map.singleton parent (Map.keysSet exclusions) <> deeperFinds
246240
247241-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
248242foldPathTreeFor
@@ -304,16 +298,15 @@ parseCabalPackage
304298 -> m (Maybe CabalPackageInfo)
305299parseCabalPackage dir = parseCabalPackage' dir >>= \case
306300 Left err -> Nothing <$ putLog Error err
307− Right (Just (warnings, pkgInfo)) -> do
301+ Right (warnings, pkgInfo) -> do
308302 for_ warnings $ putLog Warning . T.pack . show
309303 pure $ Just pkgInfo
310− Right Nothing -> pure Nothing
311304
312305-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313306parseCabalPackage'
314307 :: (MonadIO m)
315308 => FilePath -- ^ Package directory
316− -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
309+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
317310parseCabalPackage' pkg = runExceptT $ do
318311 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319312 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -341,7 +334,7 @@ parseCabalPackage' pkg = runExceptT $ do
341334 case condLibrary <$> result of
342335 Right (Just condLib) -> do
343336 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ Just $ (warnings,) $ CabalPackageInfo
337+ pure $ (warnings,) $ CabalPackageInfo
345338 { _cabalPackageInfo_packageName = T.pack packageName
346339 , _cabalPackageInfo_packageFile = packageFile
347340 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -353,19 +346,18 @@ parseCabalPackage' pkg = runExceptT $ do
353346 , _cabalPackageInfo_defaultLanguage =
354347 defaultLanguage $ libBuildInfo lib
355348 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356− , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
357349 }
358− Right Nothing -> pure Nothing
350+ Right Nothing -> throwError "Haskell package has no library component"
359351 Left (_, errors) ->
360352 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
361353
362354parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
363355parsePackagesOrFail dirs' = do
364− packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
356+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
365357 flip fmap (parseCabalPackage dir) $ \case
366358 Just packageInfo
367− | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368− _ -> Nothing
359+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
360+ _ -> Left dir
369361
370362 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371363 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -387,6 +379,9 @@ parsePackagesOrFail dirs' = do
387379 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
388380 Just xs -> pure xs
389381
382+ unless (null pkgDirErrs) $
383+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
384+
390385 pure packageInfos
391386 where
392387 dirs = toList dirs'
@@ -394,129 +389,104 @@ parsePackagesOrFail dirs' = do
394389packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395390packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
396391
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−
412392-- | Create ghci configuration to load the given packages
413393withGhciScript
414394 :: (MonadObelisk m, Foldable f)
415− => [String] -- ^ Commands to prefix to file
416− -> f CabalPackageInfo -- ^ List of packages to load into ghci
395+ => f CabalPackageInfo -- ^ List of packages to load into ghci
396+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
417397 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
418398 -> m ()
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
399+withGhciScript (toList -> packageInfos) pathBase f = do
400+ ghciSettings <- getGhciSessionSettings packageInfos pathBase
401+ let
425402 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
426403 modulesToLoad = mconcat
427404 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
428405 , [ "Backend" | "backend" `Set.member` packageNames ]
429406 , [ "Frontend" | "frontend" `Set.member` packageNames ]
430407 ]
431− dotGhci = unlines $
432− preCommands <>
433− [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
408+ dotGhci = unlines
409+ [ ":set " <> unwords ghciSettings -- TODO: Shell escape
410+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434411 , "import qualified Obelisk.Run"
435412 , "import qualified Frontend"
436− , "import qualified Backend"
437− ]
413+ , "import qualified Backend" ]
414+ withSystemTempDirectory "ob-ghci" $ \fp -> do
415+ let dotGhciPath = fp </> ".ghci"
416+ liftIO $ writeFile dotGhciPath dotGhci
417+ f dotGhciPath
438418
439419-- | Builds a list of options to pass to ghci or set in .ghci file that configures
440420-- the preprocessor and source includes.
441421getGhciSessionSettings
442422 :: (MonadObelisk m, Foldable f)
443423 => f CabalPackageInfo -- ^ List of packages to load into ghci
444− -> FilePath -- ^ All paths will be relative to this path
445− -> Bool -- ^ Use relative paths
424+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
446425 -> m [String]
447−getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
448− -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
449− -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
450− -- all paths to 'pathBase'.
451− selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
452− canonicalPathBase <- liftIO $ canonicalizePath pathBase
453−
454− (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
455− canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
456− canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
457− pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
458−
426+getGhciSessionSettings (toList -> packageInfos) pathBase = do
427+ selfExe <- liftIO getExecutablePath
428+ -- TODO: Shell escape
459429 pure
460− $ baseGhciOptions
461− <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
462− <> concatMap (\p -> ["-optF", p]) pkgFiles
463− <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
430+ $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
431+ <> concatMap (\p -> ["-optF", makeRelative pathBase $ _cabalPackageInfo_packageFile p]) packageInfos
432+ <> [ "-i" <> intercalate ":" (packageInfos >>= rootedSourceDirs) ]
464433 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− ]
434+ rootedSourceDirs pkg = NE.toList $
435+ makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
473436
474437-- | Run ghci repl
475438runGhciRepl
476439 :: (MonadObelisk m, Foldable f)
477440 => FilePath -- ^ Path to project root
478− -> f CabalPackageInfo -- ^ Packages to keep unbuilt
479− -> [String] -- ^ GHCi arguments
441+ -> f CabalPackageInfo
442+ -> FilePath -- ^ Path to .ghci
480443 -> m ()
481−runGhciRepl root (toList -> packages) ghciArgs =
444+runGhciRepl root (toList -> packages) dotGhci =
482445 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
483446 -- ghc that is provided by the shell in the user's project.
484− nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485− Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
447+ nixShellWithPkgs root True False (packageInfoToNamePathMap packages) "ghc" $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
486448
487449-- | Run ghcid
488450runGhcid
489451 :: (MonadObelisk m, Foldable f)
490452 => FilePath -- ^ Path to project root
491453 -> Bool -- ^ Should we chdir to root when running this process?
492− -> [String] -- ^ GHCi arguments
493− -> f CabalPackageInfo -- ^ Packages to keep unbuilt
454+ -> FilePath -- ^ Path to .ghci
455+ -> f CabalPackageInfo
494456 -> Maybe String -- ^ Optional command to run at every reload
495457 -> m ()
496−runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497− nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498− Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
458+runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
459+ nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
499460 where
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− ]
461+ opts =
462+ [ "-W"
463+ , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
464+ , "--outputfile=ghcid-output.txt"
465+ ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
466+ <> map (\x -> "--restart='" <> x <> "'") restartFiles
467+ <> testCmd
468+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
469+
508470 adjustRoot x = if chdirToRoot then makeRelative root x else x
509471 reloadFiles = map adjustRoot [root </> "config"]
510472 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
511473
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
474+makeBaseGhciOptions :: FilePath -> String
475+makeBaseGhciOptions dotGhci =
476+ unwords
477+ [ "-no-user-package-db"
478+ , "-package-env -"
479+ , "-ghci-script " <> dotGhci
480+ ]
481+
482+getFreePort :: MonadIO m => m PortNumber
483+getFreePort = liftIO $ withSocketsDo $ do
484+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
485+ bracket (open addr) close socketPort
516486 where
517487 open addr = do
518− sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519− Socket.bind sock (Socket.addrAddress addr)
488+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
489+ bind sock (addrAddress addr)
520490 return sock
521491
522492
@@ -526,29 +496,3 @@ pathToTree a p = go $ splitDirectories p
526496 where
527497 go [] = PathTree_Node (Just a) mempty
528498 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 (</>) ""