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