@@ -14,20 +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
30−import Data.Maybe
33+import qualified Data.Map.Monoidal as MMap
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
31import Data.Set (Set)
36import Data.Set (Set)
32import qualified Data.Set as Set
37import qualified Data.Set as Set
33import Data.String.Here.Interpolated (i)
38import Data.String.Here.Interpolated (i)
@@ -41,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
41import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
42import Distribution.Parsec.ParseResult (runParseResult)
47import Distribution.Parsec.ParseResult (runParseResult)
43import qualified Distribution.System as Dist
48import qualified Distribution.System as Dist
44−import Distribution.Types.BuildInfo
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
45−import Distribution.Types.CondTree
50+import Distribution.Types.CondTree (simplifyCondTree)
46−import Distribution.Types.GenericPackageDescription
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
47−import Distribution.Types.Library
52+import Distribution.Types.Library (libBuildInfo)
48−import Distribution.Utils.Generic
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
49import qualified Distribution.Parsec.Common as Dist
54import qualified Distribution.Parsec.Common as Dist
50import qualified Hpack.Config as Hpack
55import qualified Hpack.Config as Hpack
51import qualified Hpack.Render as Hpack
56import qualified Hpack.Render as Hpack
52import qualified Hpack.Yaml as Hpack
57import qualified Hpack.Yaml as Hpack
53−import Language.Haskell.Extension
58+import Language.Haskell.Extension (Extension, Language)
54−import Network.Socket hiding (Debug)
59+import qualified Network.Socket as Socket
55import System.Directory
60import System.Directory
56import System.Environment (getExecutablePath)
61import System.Environment (getExecutablePath)
57import System.FilePath
62import System.FilePath
@@ -61,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
61import Obelisk.App (MonadObelisk)
66import Obelisk.App (MonadObelisk)
62import Obelisk.CliApp (
67import Obelisk.CliApp (
63 Severity (..),
68 Severity (..),
68 readCreateProcessWithExitCode,
72 readCreateProcessWithExitCode,
69 readProcessAndLogStderr,
73 readProcessAndLogStderr,
71 setDelegateCtlc,
76 setDelegateCtlc,
73 withSpinner,
77 withSpinner,
75import Obelisk.Command.Nix
79import Obelisk.Command.Nix
76−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
77import Obelisk.Command.Thunk (attrCacheFileName)
81import Obelisk.Command.Thunk (attrCacheFileName)
78import Obelisk.Command.Utils (findExePath, ghcidExePath)
82import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -90,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
90 -- ^ List of globally set languages of the library component
94 -- ^ List of globally set languages of the library component
91 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
95 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
92 -- ^ 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)
95−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
96data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
98textInterpret :: Interpret -> Text
104textInterpret :: Interpret -> Text
@@ -106,9 +112,6 @@ data PathTree a = PathTree_Node
106 (Map FilePath (PathTree a)) -- Branches to deeper leaves
112 (Map FilePath (PathTree a)) -- Branches to deeper leaves
107 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
113 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
109−emptyPathTree :: PathTree a
110−emptyPathTree = PathTree_Node Nothing mempty
112-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
115-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
113drawPathTree :: (a -> Text) -> PathTree a -> Text
116drawPathTree :: (a -> Text) -> PathTree a -> Text
114drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
117drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -148,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
148 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
149 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)
150 freePort <- getFreePort
153 freePort <- getFreePort
151− (_, _, _, 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") $
152 [ show freePort
155 [ show freePort
153 , T.unpack assets
156 , T.unpack assets
154 , profileBaseName
157 , profileBaseName
@@ -156,16 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
156 , "-po" <> profileBaseName
159 , "-po" <> profileBaseName
157 ] <> rtsFlags
160 ] <> rtsFlags
158 <> [ "-RTS" ]
161 <> [ "-RTS" ]
159− void $ waitForProcess ph
161run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
162run root interpretPaths = do
164run root interpretPaths = do
163 pkgs <- getParsedLocalPkgs root interpretPaths
165 pkgs <- getParsedLocalPkgs root interpretPaths
164− withGhciScript pkgs root $ \dotGhciPath -> do
165− freePort <- getFreePort
166− assets <- findProjectAssets root
166+ assets <- findProjectAssets root
167− 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
168− runGhcid root True dotGhciPath pkgs $ Just $ unwords
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
169 [ "Obelisk.Run.run"
172 [ "Obelisk.Run.run"
170 , show freePort
173 , show freePort
171 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -176,24 +179,26 @@ run root interpretPaths = do
176runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
179runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
177runRepl root interpretPaths = do
180runRepl root interpretPaths = do
178 pkgs <- getParsedLocalPkgs root interpretPaths
181 pkgs <- getParsedLocalPkgs root interpretPaths
179− withGhciScript pkgs "." $ \dotGhciPath ->
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
180− runGhciRepl root pkgs dotGhciPath
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
182runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
183runWatch root interpretPaths = do
187runWatch root interpretPaths = do
184 pkgs <- getParsedLocalPkgs root interpretPaths
188 pkgs <- getParsedLocalPkgs root interpretPaths
185− withGhciScript pkgs root $ \dotGhciPath ->
189+ ghciArgs <- getGhciSessionSettings pkgs root True
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
186− runGhcid root True dotGhciPath pkgs Nothing
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
188−exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
189−exportGhciConfig root interpretPaths = do
194+exportGhciConfig useRelativePaths root interpretPaths = do
190 pkgs <- getParsedLocalPkgs root interpretPaths
195 pkgs <- getParsedLocalPkgs root interpretPaths
191− getGhciSessionSettings pkgs "."
196+ getGhciSessionSettings pkgs "." useRelativePaths
193nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
198nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
194nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
195 pkgs <- getParsedLocalPkgs root interpretPaths
200 pkgs <- getParsedLocalPkgs root interpretPaths
196− nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
201+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
198-- | 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.
199getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
204getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
@@ -211,11 +216,12 @@ getLocalPkgs root interpretPaths = do
212 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
213 -- obelisk project is our own.
218 -- obelisk project is our own.
214− obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $ filter (/= root) $ map takeDirectory obeliskPackagePaths
219+ obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
220+ filter (/= root) $ map takeDirectory obeliskPackagePaths
215 putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
221 putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
216 let rootsAndExclusions = calcIntepretFinds "" interpretPaths
222 let rootsAndExclusions = calcIntepretFinds "" interpretPaths
218− fmap fold $ for (Map.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
224+ fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
219 let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
225 let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
220 in fmap (Set.fromList . map normalise) $ runFind $
226 in fmap (Set.fromList . map normalise) $ runFind $
221 ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
227 ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
@@ -229,14 +235,14 @@ getLocalPkgs root interpretPaths = do
229-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
235-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
230-- This is used when constructing a set of @find@ commands to run to produce a set of packages
236-- This is used when constructing a set of @find@ commands to run to produce a set of packages
231-- that matches the user's @--interpret@/@--no-interpret@ settings.
237-- that matches the user's @--interpret@/@--no-interpret@ settings.
232−calcIntepretFinds :: FilePath -> PathTree Interpret -> Map FilePath (Set FilePath)
238+calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
233calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
239calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
235 go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
241 go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
236 exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
242 exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
237 pure $ Map.singleton parent' children'
243 pure $ Map.singleton parent' children'
238− deeperFinds <- fmap fold $ Map.traverseWithKey go exclusions
244+ deeperFinds <- Map.traverseWithKey go exclusions
239− pure $ Map.singleton parent (Map.keysSet exclusions) <> deeperFinds
245+ pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
241-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
247-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
242foldPathTreeFor
248foldPathTreeFor
@@ -298,15 +304,16 @@ parseCabalPackage
298 -> m (Maybe CabalPackageInfo)
304 -> m (Maybe CabalPackageInfo)
299parseCabalPackage dir = parseCabalPackage' dir >>= \case
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
300 Left err -> Nothing <$ putLog Error err
306 Left err -> Nothing <$ putLog Error err
301− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
302 for_ warnings $ putLog Warning . T.pack . show
308 for_ warnings $ putLog Warning . T.pack . show
303 pure $ Just pkgInfo
309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
305-- | 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'.
306parseCabalPackage'
313parseCabalPackage'
307 :: (MonadIO m)
314 :: (MonadIO m)
308 => FilePath -- ^ Package directory
315 => FilePath -- ^ Package directory
309− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
310parseCabalPackage' pkg = runExceptT $ do
317parseCabalPackage' pkg = runExceptT $ do
311 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
312 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
@@ -334,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
334 case condLibrary <$> result of
341 case condLibrary <$> result of
335 Right (Just condLib) -> do
342 Right (Just condLib) -> do
336 let (_, lib) = simplifyCondTree evalConfVar condLib
343 let (_, lib) = simplifyCondTree evalConfVar condLib
337− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
338 { _cabalPackageInfo_packageName = T.pack packageName
345 { _cabalPackageInfo_packageName = T.pack packageName
339 , _cabalPackageInfo_packageFile = packageFile
346 , _cabalPackageInfo_packageFile = packageFile
340 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -346,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
346 , _cabalPackageInfo_defaultLanguage =
353 , _cabalPackageInfo_defaultLanguage =
347 defaultLanguage $ libBuildInfo lib
354 defaultLanguage $ libBuildInfo lib
348 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
350− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
351 Left (_, errors) ->
359 Left (_, errors) ->
352 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)
354parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
355parsePackagesOrFail dirs' = do
363parsePackagesOrFail dirs' = do
356− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
357 flip fmap (parseCabalPackage dir) $ \case
365 flip fmap (parseCabalPackage dir) $ \case
358 Just packageInfo
366 Just packageInfo
359− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
360− _ -> Left dir
368+ _ -> Nothing
362 -- 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.
363 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))
@@ -379,9 +387,6 @@ parsePackagesOrFail dirs' = do
379 "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)
380 Just xs -> pure xs
388 Just xs -> pure xs
382− unless (null pkgDirErrs) $
383− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
385 pure packageInfos
390 pure packageInfos
387 dirs = toList dirs'
392 dirs = toList dirs'
@@ -389,104 +394,129 @@ parsePackagesOrFail dirs' = do
389packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
390packageInfoToNamePathMap = 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
392-- | Create ghci configuration to load the given packages
412-- | Create ghci configuration to load the given packages
393withGhciScript
413withGhciScript
394 :: (MonadObelisk m, Foldable f)
414 :: (MonadObelisk m, Foldable f)
415+ => [String] -- ^ Commands to prefix to file
395− => f CabalPackageInfo -- ^ List of packages to load into ghci
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
396− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
397 -> (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
399−withGhciScript (toList -> packageInfos) pathBase f = do
419+withGhciScript preCommands (toList -> packageInfos) f =
400− ghciSettings <- getGhciSessionSettings packageInfos pathBase
420+ withSystemTempDirectory "ob-ghci" $ \fp -> do
401− let
421+ let dotGhciPath = fp </> ".ghci"
422+ liftIO $ writeFile dotGhciPath dotGhci
402 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
403 modulesToLoad = mconcat
426 modulesToLoad = mconcat
404 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
405 , [ "Backend" | "backend" `Set.member` packageNames ]
428 , [ "Backend" | "backend" `Set.member` packageNames ]
406 , [ "Frontend" | "frontend" `Set.member` packageNames ]
429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
408− dotGhci = unlines
431+ dotGhci = unlines $
409− [ ":set " <> unwords ghciSettings -- TODO: Shell escape
432+ preCommands <>
410− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
411 , "import qualified Obelisk.Run"
434 , "import qualified Obelisk.Run"
412 , "import qualified Frontend"
435 , "import qualified Frontend"
413− , "import qualified Backend" ]
436+ , "import qualified Backend"
414− withSystemTempDirectory "ob-ghci" $ \fp -> do
437+ ]
415− let dotGhciPath = fp </> ".ghci"
416− liftIO $ writeFile dotGhciPath dotGhci
419-- | 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
420-- the preprocessor and source includes.
440-- the preprocessor and source includes.
421getGhciSessionSettings
441getGhciSessionSettings
422 :: (MonadObelisk m, Foldable f)
442 :: (MonadObelisk m, Foldable f)
423 => f CabalPackageInfo -- ^ List of packages to load into ghci
443 => f CabalPackageInfo -- ^ List of packages to load into ghci
424− -> 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
425 -> m [String]
446 -> m [String]
426−getGhciSessionSettings (toList -> packageInfos) pathBase = do
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'.
427− selfExe <- liftIO getExecutablePath
451+ selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
428− -- TODO: Shell escape
452+ canonicalPathBase <- liftIO $ canonicalizePath pathBase
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)
430− $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
431− <> concatMap (\p -> ["-optF", makeRelative pathBase $ _cabalPackageInfo_packageFile p]) packageInfos
462+ <> concatMap (\p -> ["-optF", p]) pkgFiles
432− <> [ "-i" <> intercalate ":" (packageInfos >>= rootedSourceDirs) ]
463+ <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
434− rootedSourceDirs pkg = NE.toList $
465+ relativeTo' = if useRelativePaths then relativeTo else const
435− makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
466+
467+baseGhciOptions :: [String]
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
437-- | Run ghci repl
474-- | Run ghci repl
438runGhciRepl
475runGhciRepl
439 :: (MonadObelisk m, Foldable f)
476 :: (MonadObelisk m, Foldable f)
440 => FilePath -- ^ Path to project root
477 => FilePath -- ^ Path to project root
441− -> f CabalPackageInfo
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
442− -> FilePath -- ^ Path to .ghci
479+ -> [String] -- ^ GHCi arguments
444−runGhciRepl root (toList -> packages) dotGhci =
481+runGhciRepl root (toList -> packages) ghciArgs =
445 -- 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
446 -- 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.
447− 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
449-- | Run ghcid
487-- | Run ghcid
451 :: (MonadObelisk m, Foldable f)
489 :: (MonadObelisk m, Foldable f)
452 => FilePath -- ^ Path to project root
490 => FilePath -- ^ Path to project root
453 -> Bool -- ^ Should we chdir to root when running this process?
491 -> Bool -- ^ Should we chdir to root when running this process?
454− -> FilePath -- ^ Path to .ghci
492+ -> [String] -- ^ GHCi arguments
455− -> f CabalPackageInfo
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
456 -> Maybe String -- ^ Optional command to run at every reload
494 -> Maybe String -- ^ Optional command to run at every reload
458−runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
459− 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
461− opts =
500+ opts = concat
463− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
464− , "--outputfile=ghcid-output.txt"
502+ , ["--outputfile=ghcid-output.txt"]
465− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
503+ , map (\x -> "--reload=" <> x) reloadFiles
466− <> map (\x -> "--restart='" <> x <> "'") restartFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
467− <> testCmd
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
468− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
470 adjustRoot x = if chdirToRoot then makeRelative root x else x
508 adjustRoot x = if chdirToRoot then makeRelative root x else x
471 reloadFiles = map adjustRoot [root </> "config"]
509 reloadFiles = map adjustRoot [root </> "config"]
472 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
474−makeBaseGhciOptions :: FilePath -> String
475−makeBaseGhciOptions dotGhci =
477− [ "-no-user-package-db"
479− , "-ghci-script " <> dotGhci
482−getFreePort :: MonadIO m => m PortNumber
512+getFreePort :: MonadIO m => m Socket.PortNumber
483−getFreePort = liftIO $ withSocketsDo $ do
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
484− 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")
485− bracket (open addr) close socketPort
515+ bracket (open addr) Socket.close Socket.socketPort
487 open addr = do
517 open addr = do
488− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
489− bind sock (addrAddress addr)
519+ Socket.bind sock (Socket.addrAddress addr)
490 return sock
520 return sock
@@ -496,3 +526,29 @@ pathToTree a p = go $ splitDirectories p
497 go [] = PathTree_Node (Just a) mempty
527 go [] = PathTree_Node (Just a) mempty
498 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 (</>) ""