@@ -14,21 +14,25 @@ module Obelisk.Command.Run where
14import Control.Arrow ((&&&))
14import Control.Arrow ((&&&))
15import Control.Exception (Exception, bracket)
15import Control.Exception (Exception, bracket)
16import Control.Lens (ifor, (.~), (&))
16import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
18import Control.Monad.Except (runExceptT, throwError)
18import Control.Monad.Except (runExceptT, throwError)
19import Control.Monad.IO.Class (liftIO)
19import Control.Monad.IO.Class (liftIO)
20import Control.Monad.Reader (MonadIO)
20import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
21import Data.Coerce (coerce)
23import Data.Coerce (coerce)
22import Data.Default (def)
24import Data.Default (def)
23import Data.Either (partitionEithers)
25import Data.Either (partitionEithers)
24import Data.Foldable (fold, for_, toList)
26import Data.Foldable (fold, for_, toList)
25import Data.Functor.Identity (runIdentity)
27import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
26import Data.List.NonEmpty (NonEmpty)
29import Data.List.NonEmpty (NonEmpty)
27import qualified Data.List.NonEmpty as NE
30import qualified Data.List.NonEmpty as NE
28import Data.Map (Map)
31import Data.Map (Map)
29import qualified Data.Map as Map
32import qualified Data.Map as Map
30import qualified Data.Map.Monoidal as MMap
33import qualified Data.Map.Monoidal as MMap
31−import Data.Maybe
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
32import Data.Set (Set)
36import Data.Set (Set)
33import qualified Data.Set as Set
37import qualified Data.Set as Set
34import Data.String.Here.Interpolated (i)
38import Data.String.Here.Interpolated (i)
@@ -42,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
42import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
43import Distribution.Parsec.ParseResult (runParseResult)
47import Distribution.Parsec.ParseResult (runParseResult)
44import qualified Distribution.System as Dist
48import qualified Distribution.System as Dist
45−import Distribution.Types.BuildInfo
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
46−import Distribution.Types.CondTree
50+import Distribution.Types.CondTree (simplifyCondTree)
47−import Distribution.Types.GenericPackageDescription
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
48−import Distribution.Types.Library
52+import Distribution.Types.Library (libBuildInfo)
49−import Distribution.Utils.Generic
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
50import qualified Distribution.Parsec.Common as Dist
54import qualified Distribution.Parsec.Common as Dist
51import qualified Hpack.Config as Hpack
55import qualified Hpack.Config as Hpack
52import qualified Hpack.Render as Hpack
56import qualified Hpack.Render as Hpack
53import qualified Hpack.Yaml as Hpack
57import qualified Hpack.Yaml as Hpack
54−import Language.Haskell.Extension
58+import Language.Haskell.Extension (Extension, Language)
55−import Network.Socket hiding (Debug)
59+import qualified Network.Socket as Socket
56import System.Directory
60import System.Directory
57import System.Environment (getExecutablePath)
61import System.Environment (getExecutablePath)
58import System.FilePath
62import System.FilePath
@@ -62,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
62import Obelisk.App (MonadObelisk)
66import Obelisk.App (MonadObelisk)
63import Obelisk.CliApp (
67import Obelisk.CliApp (
64 Severity (..),
68 Severity (..),
69 readCreateProcessWithExitCode,
72 readCreateProcessWithExitCode,
70 readProcessAndLogStderr,
73 readProcessAndLogStderr,
72 setDelegateCtlc,
76 setDelegateCtlc,
74 withSpinner,
77 withSpinner,
76import Obelisk.Command.Nix
79import Obelisk.Command.Nix
77−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
78import Obelisk.Command.Thunk (attrCacheFileName)
81import Obelisk.Command.Thunk (attrCacheFileName)
79import Obelisk.Command.Utils (findExePath, ghcidExePath)
82import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -91,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
91 -- ^ List of globally set languages of the library component
94 -- ^ List of globally set languages of the library component
92 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
95 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
93 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
96 -- ^ 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)
96−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
97data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
99textInterpret :: Interpret -> Text
104textInterpret :: Interpret -> Text
@@ -107,9 +112,6 @@ data PathTree a = PathTree_Node
107 (Map FilePath (PathTree a)) -- Branches to deeper leaves
112 (Map FilePath (PathTree a)) -- Branches to deeper leaves
108 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
113 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
110−emptyPathTree :: PathTree a
111−emptyPathTree = PathTree_Node Nothing mempty
113-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
115-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
114drawPathTree :: (a -> Text) -> PathTree a -> Text
116drawPathTree :: (a -> Text) -> PathTree a -> Text
115drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
117drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -149,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
149 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
150 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
151 freePort <- getFreePort
153 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") $
153 [ show freePort
155 [ show freePort
154 , T.unpack assets
156 , T.unpack assets
155 , profileBaseName
157 , profileBaseName
@@ -157,16 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
157 , "-po" <> profileBaseName
159 , "-po" <> profileBaseName
158 ] <> rtsFlags
160 ] <> rtsFlags
159 <> [ "-RTS" ]
161 <> [ "-RTS" ]
160− void $ waitForProcess ph
162run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163run root interpretPaths = do
164run root interpretPaths = do
164 pkgs <- getParsedLocalPkgs root interpretPaths
165 pkgs <- getParsedLocalPkgs root interpretPaths
165− withGhciScript pkgs root $ \dotGhciPath -> do
166− freePort <- getFreePort
167− assets <- findProjectAssets root
166+ assets <- findProjectAssets root
168− putLog Debug $ "Assets impurely loaded from: " <> assets
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ ghciArgs <- getGhciSessionSettings pkgs root True
169+ freePort <- getFreePort
170+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
169− runGhcid root True dotGhciPath pkgs $ Just $ unwords
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
170 [ "Obelisk.Run.run"
172 [ "Obelisk.Run.run"
171 , show freePort
173 , show freePort
172 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -177,24 +179,26 @@ run root interpretPaths = do
177runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
179runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
178runRepl root interpretPaths = do
180runRepl root interpretPaths = do
179 pkgs <- getParsedLocalPkgs root interpretPaths
181 pkgs <- getParsedLocalPkgs root interpretPaths
180− withGhciScript pkgs "." $ \dotGhciPath ->
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
181− runGhciRepl root pkgs dotGhciPath
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
183runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
184runWatch root interpretPaths = do
187runWatch root interpretPaths = do
185 pkgs <- getParsedLocalPkgs root interpretPaths
188 pkgs <- getParsedLocalPkgs root interpretPaths
186− withGhciScript pkgs root $ \dotGhciPath ->
189+ ghciArgs <- getGhciSessionSettings pkgs root True
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
187− runGhcid root True dotGhciPath pkgs Nothing
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
189−exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
190−exportGhciConfig root interpretPaths = do
194+exportGhciConfig useRelativePaths root interpretPaths = do
191 pkgs <- getParsedLocalPkgs root interpretPaths
195 pkgs <- getParsedLocalPkgs root interpretPaths
192− getGhciSessionSettings pkgs "."
196+ getGhciSessionSettings pkgs "." useRelativePaths
194nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
198nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
195nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
196 pkgs <- getParsedLocalPkgs root interpretPaths
200 pkgs <- getParsedLocalPkgs root interpretPaths
197− nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
201+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
199-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
203-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
200getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
204getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
@@ -300,15 +304,16 @@ parseCabalPackage
300 -> m (Maybe CabalPackageInfo)
304 -> m (Maybe CabalPackageInfo)
301parseCabalPackage dir = parseCabalPackage' dir >>= \case
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
302 Left err -> Nothing <$ putLog Error err
306 Left err -> Nothing <$ putLog Error err
303− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
304 for_ warnings $ putLog Warning . T.pack . show
308 for_ warnings $ putLog Warning . T.pack . show
305 pure $ Just pkgInfo
309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
307-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
308parseCabalPackage'
313parseCabalPackage'
309 :: (MonadIO m)
314 :: (MonadIO m)
310 => FilePath -- ^ Package directory
315 => FilePath -- ^ Package directory
311− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
312parseCabalPackage' pkg = runExceptT $ do
317parseCabalPackage' pkg = runExceptT $ do
313 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
314 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -336,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
336 case condLibrary <$> result of
341 case condLibrary <$> result of
337 Right (Just condLib) -> do
342 Right (Just condLib) -> do
338 let (_, lib) = simplifyCondTree evalConfVar condLib
343 let (_, lib) = simplifyCondTree evalConfVar condLib
339− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
340 { _cabalPackageInfo_packageName = T.pack packageName
345 { _cabalPackageInfo_packageName = T.pack packageName
341 , _cabalPackageInfo_packageFile = packageFile
346 , _cabalPackageInfo_packageFile = packageFile
342 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -348,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
348 , _cabalPackageInfo_defaultLanguage =
353 , _cabalPackageInfo_defaultLanguage =
349 defaultLanguage $ libBuildInfo lib
354 defaultLanguage $ libBuildInfo lib
350 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
352− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
353 Left (_, errors) ->
359 Left (_, errors) ->
354 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
356parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
357parsePackagesOrFail dirs' = do
363parsePackagesOrFail dirs' = do
358− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
359 flip fmap (parseCabalPackage dir) $ \case
365 flip fmap (parseCabalPackage dir) $ \case
360 Just packageInfo
366 Just packageInfo
361− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
362− _ -> Left dir
368+ _ -> Nothing
364 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
365 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -381,9 +387,6 @@ parsePackagesOrFail dirs' = do
381 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
387 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
382 Just xs -> pure xs
388 Just xs -> pure xs
384− unless (null pkgDirErrs) $
385− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
387 pure packageInfos
390 pure packageInfos
389 dirs = toList dirs'
392 dirs = toList dirs'
@@ -391,41 +394,57 @@ parsePackagesOrFail dirs' = do
391packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
392packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
397+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
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
403+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
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
394-- | Create ghci configuration to load the given packages
412-- | Create ghci configuration to load the given packages
395withGhciScript
413withGhciScript
396 :: (MonadObelisk m, Foldable f)
414 :: (MonadObelisk m, Foldable f)
415+ => [String] -- ^ Commands to prefix to file
397− => f CabalPackageInfo -- ^ List of packages to load into ghci
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
398− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
399 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
401−withGhciScript (toList -> packageInfos) pathBase f = do
419+withGhciScript preCommands (toList -> packageInfos) f =
402− ghciSettings <- getGhciSessionSettings packageInfos pathBase
420+ withSystemTempDirectory "ob-ghci" $ \fp -> do
403− let
421+ let dotGhciPath = fp </> ".ghci"
422+ liftIO $ writeFile dotGhciPath dotGhci
404 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
405 modulesToLoad = mconcat
426 modulesToLoad = mconcat
406 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
407 , [ "Backend" | "backend" `Set.member` packageNames ]
428 , [ "Backend" | "backend" `Set.member` packageNames ]
408 , [ "Frontend" | "frontend" `Set.member` packageNames ]
429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
410− dotGhci = unlines
431+ dotGhci = unlines $
411− [ ":set " <> unwords ghciSettings -- TODO: Shell escape
432+ preCommands <>
412− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
413 , "import qualified Obelisk.Run"
434 , "import qualified Obelisk.Run"
414 , "import qualified Frontend"
435 , "import qualified Frontend"
415− , "import qualified Backend" ]
436+ , "import qualified Backend"
416− withSystemTempDirectory "ob-ghci" $ \fp -> do
437+ ]
417− let dotGhciPath = fp </> ".ghci"
418− liftIO $ writeFile dotGhciPath dotGhci
421-- | Builds a list of options to pass to ghci or set in .ghci file that configures
439-- | Builds a list of options to pass to ghci or set in .ghci file that configures
422-- the preprocessor and source includes.
440-- the preprocessor and source includes.
423getGhciSessionSettings
441getGhciSessionSettings
424 :: (MonadObelisk m, Foldable f)
442 :: (MonadObelisk m, Foldable f)
425 => f CabalPackageInfo -- ^ List of packages to load into ghci
443 => 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
427 -> m [String]
446 -> m [String]
428−getGhciSessionSettings (toList -> packageInfos) pathBase = do
447+getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
429 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
448 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
430 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
449 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
431 -- all paths to 'pathBase'.
450 -- all paths to 'pathBase'.
@@ -435,66 +454,69 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do
435 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
454 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
436 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
455 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
437 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
456 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
438− pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)
457+ pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
441− $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
442 <> concatMap (\p -> ["-optF", p]) pkgFiles
462 <> concatMap (\p -> ["-optF", p]) pkgFiles
443 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
463 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
465+ relativeTo' = if useRelativePaths then relativeTo else const
467+baseGhciOptions :: [String]
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
445-- | Run ghci repl
474-- | Run ghci repl
446runGhciRepl
475runGhciRepl
447 :: (MonadObelisk m, Foldable f)
476 :: (MonadObelisk m, Foldable f)
448 => FilePath -- ^ Path to project root
477 => FilePath -- ^ Path to project root
449− -> f CabalPackageInfo
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
450− -> FilePath -- ^ Path to .ghci
479+ -> [String] -- ^ GHCi arguments
452−runGhciRepl root (toList -> packages) dotGhci =
481+runGhciRepl root (toList -> packages) ghciArgs =
453 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
454 -- ghc that is provided by the shell in the user's project.
483 -- 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
457-- | Run ghcid
487-- | Run ghcid
459 :: (MonadObelisk m, Foldable f)
489 :: (MonadObelisk m, Foldable f)
460 => FilePath -- ^ Path to project root
490 => FilePath -- ^ Path to project root
461 -> Bool -- ^ Should we chdir to root when running this process?
491 -> Bool -- ^ Should we chdir to root when running this process?
462− -> FilePath -- ^ Path to .ghci
492+ -> [String] -- ^ GHCi arguments
463− -> f CabalPackageInfo
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
464 -> Maybe String -- ^ Optional command to run at every reload
494 -> Maybe String -- ^ Optional command to run at every reload
466−runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
467− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
497+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
469− opts =
500+ opts = concat
471− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
472− , "--outputfile=ghcid-output.txt"
502+ , ["--outputfile=ghcid-output.txt"]
473− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
503+ , map (\x -> "--reload=" <> x) reloadFiles
474− <> map (\x -> "--restart='" <> x <> "'") restartFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
475− <> testCmd
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
476− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
478 adjustRoot x = if chdirToRoot then makeRelative root x else x
508 adjustRoot x = if chdirToRoot then makeRelative root x else x
479 reloadFiles = map adjustRoot [root </> "config"]
509 reloadFiles = map adjustRoot [root </> "config"]
480 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
482−makeBaseGhciOptions :: FilePath -> String
483−makeBaseGhciOptions dotGhci =
485− [ "-no-user-package-db"
487− , "-ghci-script " <> dotGhci
490−getFreePort :: MonadIO m => m PortNumber
512+getFreePort :: MonadIO m => m Socket.PortNumber
491−getFreePort = liftIO $ withSocketsDo $ do
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
492− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
493− bracket (open addr) close socketPort
515+ bracket (open addr) Socket.close Socket.socketPort
495 open addr = do
517 open addr = do
496− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
497− bind sock (addrAddress addr)
519+ Socket.bind sock (Socket.addrAddress addr)
498 return sock
520 return sock
@@ -504,3 +526,29 @@ pathToTree a p = go $ splitDirectories p
505 go [] = PathTree_Node (Just a) mempty
527 go [] = PathTree_Node (Just a) mempty
506 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
528 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
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
537+-- | Makes the first absolute path relative to the second absolute path.
539+-- Both input paths MUST be absolute.
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
548+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
550+ $ dropWhile (\(a,b) -> a == b)
551+ $ zipDefaultWith Nothing Nothing (,)
552+ (map Just $ splitDirectories base)
553+ (map Just $ splitDirectories dir)
554+ where collapse = foldr (</>) ""