git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
555 lines 26 kB history raw
1{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE QuasiQuotes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TupleSections #-}
11{-# LANGUAGE ViewPatterns #-}
12module Obelisk.Command.Run where
14import Control.Arrow ((&&&))
15import Control.Exception (Exception, bracket)
16import Control.Lens (ifor, (.~), (&))
17import Control.Monad (filterM, unless, void)
18import Control.Monad.Except (runExceptT, throwError)
19import Control.Monad.IO.Class (liftIO)
20import Control.Monad.Reader (MonadIO)
21import Data.Bifoldable (bifoldr1)
22import Data.Bifunctor (bimap)
23import Data.Coerce (coerce)
24import Data.Default (def)
25import Data.Either (partitionEithers)
26import Data.Foldable (fold, for_, toList)
27import Data.Functor.Identity (runIdentity)
28import Data.List (intercalate)
29import Data.List.NonEmpty (NonEmpty)
30import qualified Data.List.NonEmpty as NE
31import Data.Map (Map)
32import qualified Data.Map as Map
33import qualified Data.Map.Monoidal as MMap
34import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35import Data.Ord (comparing)
36import Data.Set (Set)
37import qualified Data.Set as Set
38import Data.String.Here.Interpolated (i)
39import Data.Text (Text)
40import qualified Data.Text as T
41import Data.Time.Clock (getCurrentTime)
42import Data.Time.Format (formatTime, defaultTimeLocale)
43import Data.Traversable (for)
44import Debug.Trace (trace)
45import Distribution.Compiler (CompilerFlavor(..))
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
47import Distribution.Parsec.ParseResult (runParseResult)
48import qualified Distribution.System as Dist
49import Distribution.Types.BuildInfo (buildable, defaultExtensions, defaultLanguage, hsSourceDirs, options)
50import Distribution.Types.CondTree (simplifyCondTree)
51import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
52import Distribution.Types.Library (libBuildInfo)
53import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
54import qualified Distribution.Parsec.Common as Dist
55import qualified Hpack.Config as Hpack
56import qualified Hpack.Render as Hpack
57import qualified Hpack.Yaml as Hpack
58import Language.Haskell.Extension (Extension, Language)
59import qualified Network.Socket as Socket
60import System.Directory
61import System.Environment (getExecutablePath)
62import System.FilePath
63import qualified System.Info
64import System.IO.Temp (withSystemTempDirectory)
66import Obelisk.App (MonadObelisk)
67import Obelisk.CliApp (
68 Severity (..),
69 createProcess_,
70 failWith,
71 proc,
72 putLog,
73 readCreateProcessWithExitCode,
74 readProcessAndLogStderr,
75 setCwd,
76 setDelegateCtlc,
77 waitForProcess,
78 withSpinner,
79 )
80import Obelisk.Command.Nix
81import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
82import Obelisk.Command.Thunk (attrCacheFileName)
83import Obelisk.Command.Utils (findExePath, ghcidExePath)
85data CabalPackageInfo = CabalPackageInfo
86 { _cabalPackageInfo_packageFile :: FilePath
87 , _cabalPackageInfo_packageName :: T.Text
88 , _cabalPackageInfo_packageRoot :: FilePath
89 , _cabalPackageInfo_buildable :: Bool
90 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
91 -- ^ List of hs src dirs of the library component
92 , _cabalPackageInfo_defaultExtensions :: [Extension]
93 -- ^ List of globally enable extensions of the library component
94 , _cabalPackageInfo_defaultLanguage :: Maybe Language
95 -- ^ List of globally set languages of the library component
96 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
97 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
98 }
100-- | 'Bool' with a better name for it's purpose.
101data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
103textInterpret :: Interpret -> Text
104textInterpret = \case
105 Interpret_Interpret -> "Interpret"
106 Interpret_NoInterpret -> "NoInterpret"
108-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
109data PathTree a = PathTree_Node
110 (Maybe a) -- An optional leaf at this point in the tree
111 (Map FilePath (PathTree a)) -- Branches to deeper leaves
112 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
114-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
115drawPathTree :: (a -> Text) -> PathTree a -> Text
116drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
117 where
118 annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
119 goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
120 goForest [] = []
121 goForest [tree] = shift "└─ " " " (goTree tree)
122 goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
123 shift first other = zipWith (<>) (first : repeat other)
125-- | Used to signal to obelisk that it's being invoked as a preprocessor
126preprocessorIdentifier :: String
127preprocessorIdentifier = "__preprocessor-apply-packages"
129profile
130 :: MonadObelisk m
131 => String
132 -> [String]
133 -> m ()
134profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
135 putLog Debug "Using profiled build of project."
137 outPath <- withSpinner "Building profiled executable" $
138 fmap (T.unpack . T.strip) $ readProcessAndLogStderr Debug $ setCwd (Just root) $ nixCmdProc $
139 NixCmd_Build $ def
140 & nixBuildConfig_outLink .~ OutLink_None
141 & nixCmdConfig_target .~ Target
142 { _target_path = Just "."
143 , _target_attr = Just "__unstable__.profiledObRun"
144 , _target_expr = Nothing
145 }
146 assets <- findProjectAssets root
147 putLog Debug $ "Assets impurely loaded from: " <> assets
148 time <- liftIO getCurrentTime
149 let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
150 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
151 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
152 freePort <- getFreePort
153 (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
154 [ show freePort
155 , T.unpack assets
156 , profileBaseName
157 , "+RTS"
158 , "-po" <> profileBaseName
159 ] <> rtsFlags
160 <> [ "-RTS" ]
161 void $ waitForProcess ph
163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164run root interpretPaths = do
165 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
172 [ "Obelisk.Run.run"
173 , show freePort
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
175 , "Backend.backend"
176 , "Frontend.frontend"
177 ]
179runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180runRepl root interpretPaths = do
181 pkgs <- getParsedLocalPkgs root interpretPaths
182 ghciArgs <- getGhciSessionSettings pkgs "." True
183 withGhciScriptArgs pkgs $ \dotGhciArgs ->
184 runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187runWatch root interpretPaths = do
188 pkgs <- getParsedLocalPkgs root interpretPaths
189 ghciArgs <- getGhciSessionSettings pkgs root True
190 withGhciScriptArgs pkgs $ \dotGhciArgs ->
191 runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
193exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194exportGhciConfig useRelativePaths root interpretPaths = do
195 pkgs <- getParsedLocalPkgs root interpretPaths
196 getGhciSessionSettings pkgs "." useRelativePaths
198nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200 pkgs <- getParsedLocalPkgs root interpretPaths
201 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
203-- | 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)
205getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
207-- | Relative paths to local packages of an obelisk project.
208--
209-- These are a combination of the obelisk predefined local packages,
210-- and any packages that the user has set with the @packages@ argument
211-- to the Nix @project@ function.
212getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
213getLocalPkgs root interpretPaths = do
214 putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
215 obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
218 -- obelisk project is our own.
219 obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
220 filter (/= root) $ map takeDirectory obeliskPackagePaths
221 putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
222 let rootsAndExclusions = calcIntepretFinds "" interpretPaths
224 fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
225 let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
226 in fmap (Set.fromList . map normalise) $ runFind $
227 ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
228 <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
229 where
230 runFind args = do
231 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
232 putLog Debug $ T.strip $ T.pack err
233 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
235-- | 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
237-- that matches the user's @--interpret@/@--no-interpret@ settings.
238calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
239calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
240 where
241 go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
242 exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
243 pure $ Map.singleton parent' children'
244 deeperFinds <- Map.traverseWithKey go exclusions
245 pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
247-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
248foldPathTreeFor
249 :: forall m a b. (Applicative m, Monoid b)
250 => (a -> Bool)
251 -> FilePath
252 -> PathTree a
253 -> (FilePath -> PathTree a -> m b)
254 -> m b
255foldPathTreeFor predicate parent children f = case children of
256 PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children')
257 PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' ->
258 foldPathTreeFor predicate (parent </> k) children'' f
260data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
261 deriving (Eq, Ord, Show)
262instance Exception GuessPackageFileError
264newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
265newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
267-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
268guessCabalPackageFile
269 :: (MonadIO m)
270 => FilePath -- ^ Directory or path to search for cabal package
271 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
272guessCabalPackageFile pkg = do
273 liftIO (doesDirectoryExist pkg) >>= \case
274 False -> case cabalOrHpackFile pkg of
275 (Just hpack@(Right _)) -> pure $ Right hpack
276 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
277 -- If the cabal file has a sibling hpack file, we use that instead
278 -- since running hpack often generates a sibling cabal file
279 let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
280 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
281 pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
282 Nothing -> pure $ Left GuessPackageFileError_NotFound
283 True -> do
284 candidates <- liftIO $
285 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
286 =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
287 pure $ case partitionEithers candidates of
288 ([hpack], _) -> Right $ Left hpack
289 ([], [cabal]) -> Right $ Right cabal
290 ([], []) -> Left GuessPackageFileError_NotFound
291 (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
293cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
294cabalOrHpackFile = \case
295 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
296 | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
297 | otherwise -> Nothing
299-- | Parses the cabal package in a given directory.
300-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
301parseCabalPackage
302 :: MonadObelisk m
303 => FilePath -- ^ Package directory
304 -> m (Maybe CabalPackageInfo)
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
306 Left err -> Nothing <$ putLog Error err
307 Right (warnings, pkgInfo) -> do
308 for_ warnings $ putLog Warning . T.pack . show
309 pure $ Just pkgInfo
311-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
312parseCabalPackage'
313 :: (MonadIO m)
314 => FilePath -- ^ Package directory
315 -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316parseCabalPackage' pkg = runExceptT $ do
317 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
318 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
319 Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
320 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
321 Right (Right (HPackFilePath file)) -> do
322 let
323 decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
324 liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
325 Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
326 Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
328 let
329 (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
330 osConfVar = case System.Info.os of
331 "linux" -> Just Dist.Linux
332 "darwin" -> Just Dist.OSX
333 _ -> trace "Unrecgonized System.Info.os" Nothing
334 archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
335 evalConfVar v = Right $ case v of
336 OS osVar -> Just osVar == osConfVar
337 Arch archVar -> Just archVar == archConfVar
338 Impl GHC _ -> True -- TODO: Actually check version range
339 _ -> False
340 case condLibrary <$> result of
341 Right (Just condLib) -> do
342 let (_, lib) = simplifyCondTree evalConfVar condLib
343 pure $ (warnings,) $ CabalPackageInfo
344 { _cabalPackageInfo_packageName = T.pack packageName
345 , _cabalPackageInfo_packageFile = packageFile
346 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
347 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
348 , _cabalPackageInfo_sourceDirs =
349 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
350 , _cabalPackageInfo_defaultExtensions =
351 defaultExtensions $ libBuildInfo lib
352 , _cabalPackageInfo_defaultLanguage =
353 defaultLanguage $ libBuildInfo lib
354 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
355 }
356 Right Nothing -> throwError "Haskell package has no library component"
357 Left (_, errors) ->
358 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
360parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
361parsePackagesOrFail dirs' = do
362 (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
363 flip fmap (parseCabalPackage dir) $ \case
364 Just packageInfo
365 | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
366 _ -> Left dir
368 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
369 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
370 $ Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
371 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
372 p NE.:| [] -> pure p -- No ambiguity here
373 p NE.:| _ -> do
374 let chosenText = " [Chosen] "
375 prefix p'
376 | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText
377 | otherwise = T.map (const ' ') chosenText
378 putLog Warning $ T.unlines $
379 "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "
380 : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)
381 pure p
383 packageInfos <- case NE.nonEmpty $ toList unambiguous of
384 Nothing -> failWith $ T.pack $
385 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
386 Just xs -> pure xs
388 unless (null pkgDirErrs) $
389 putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
391 pure packageInfos
392 where
393 dirs = toList dirs'
395packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
396packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
398-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
399withGhciScriptArgs
400 :: (MonadObelisk m, Foldable f)
401 => f CabalPackageInfo -- ^ List of packages to load into ghci
402 -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
403 -> m ()
404withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
405 where
406 -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
407 -- is passed to the ghci session.
408 loadPreludeManually =
409 [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
410 , ":set -XImplicitPrelude" -- Turn the default setting on
411 ]
413-- | Create ghci configuration to load the given packages
414withGhciScript
415 :: (MonadObelisk m, Foldable f)
416 => [String] -- ^ Commands to prefix to file
417 -> f CabalPackageInfo -- ^ List of packages to load into ghci
418 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
419 -> m ()
420withGhciScript preCommands (toList -> packageInfos) f =
421 withSystemTempDirectory "ob-ghci" $ \fp -> do
422 let dotGhciPath = fp </> ".ghci"
423 liftIO $ writeFile dotGhciPath dotGhci
424 f dotGhciPath
425 where
426 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
427 modulesToLoad = mconcat
428 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
429 , [ "Backend" | "backend" `Set.member` packageNames ]
430 , [ "Frontend" | "frontend" `Set.member` packageNames ]
431 ]
432 dotGhci = unlines $
433 preCommands <>
434 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
435 , "import qualified Obelisk.Run"
436 , "import qualified Frontend"
437 , "import qualified Backend"
438 ]
440-- | Builds a list of options to pass to ghci or set in .ghci file that configures
441-- the preprocessor and source includes.
442getGhciSessionSettings
443 :: (MonadObelisk m, Foldable f)
444 => f CabalPackageInfo -- ^ List of packages to load into ghci
445 -> FilePath -- ^ All paths will be relative to this path
446 -> Bool -- ^ Use relative paths
447 -> m [String]
448getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
449 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
450 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
451 -- all paths to 'pathBase'.
452 selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
453 canonicalPathBase <- liftIO $ canonicalizePath pathBase
455 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
456 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
457 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
458 pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
460 pure
461 $ baseGhciOptions
462 <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
463 <> concatMap (\p -> ["-optF", p]) pkgFiles
464 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
465 where
466 relativeTo' = if useRelativePaths then relativeTo else const
468baseGhciOptions :: [String]
469baseGhciOptions =
470 [ "-ignore-dot-ghci"
471 , "-no-user-package-db"
472 , "-package-env", "-"
473 ]
475-- | Run ghci repl
476runGhciRepl
477 :: (MonadObelisk m, Foldable f)
478 => FilePath -- ^ Path to project root
479 -> f CabalPackageInfo -- ^ Packages to keep unbuilt
480 -> [String] -- ^ GHCi arguments
481 -> m ()
482runGhciRepl root (toList -> packages) ghciArgs =
483 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
484 -- ghc that is provided by the shell in the user's project.
485 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
486 Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
488-- | Run ghcid
489runGhcid
490 :: (MonadObelisk m, Foldable f)
491 => FilePath -- ^ Path to project root
492 -> Bool -- ^ Should we chdir to root when running this process?
493 -> [String] -- ^ GHCi arguments
494 -> f CabalPackageInfo -- ^ Packages to keep unbuilt
495 -> Maybe String -- ^ Optional command to run at every reload
496 -> m ()
497runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
498 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
499 Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
500 where
501 opts = concat
502 [ ["-W"]
503 , ["--outputfile=ghcid-output.txt"]
504 , map (\x -> "--reload=" <> x) reloadFiles
505 , map (\x -> "--restart=" <> x) restartFiles
506 , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
507 , ["--command=" <> unwords ("ghci" : ghciArgs)]
508 ]
509 adjustRoot x = if chdirToRoot then makeRelative root x else x
510 reloadFiles = map adjustRoot [root </> "config"]
511 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
513getFreePort :: MonadIO m => m Socket.PortNumber
514getFreePort = liftIO $ Socket.withSocketsDo $ do
515 addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
516 bracket (open addr) Socket.close Socket.socketPort
517 where
518 open addr = do
519 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
520 Socket.bind sock (Socket.addrAddress addr)
521 return sock
524-- | Convert a 'FilePath' into a 'PathTree'.
525pathToTree :: a -> FilePath -> PathTree a
526pathToTree a p = go $ splitDirectories p
527 where
528 go [] = PathTree_Node (Just a) mempty
529 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
531-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
532zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
533zipDefaultWith _da _db _f [] [] = []
534zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
535zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
536zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
538-- | Makes the first absolute path relative to the second absolute path.
539--
540-- Both input paths MUST be absolute.
541--
542-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
543-- enough @..@ paths to make the resulting path truly relative in virtually every
544-- case. The only exception is on Windows when the two paths are on different
545-- drives. In this case the resulting path may be absolute.
546relativeTo :: FilePath -> FilePath -> FilePath
547relativeTo dir base
548 = bifoldr1 (</>)
549 $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
550 $ unzip
551 $ dropWhile (\(a,b) -> a == b)
552 $ zipDefaultWith Nothing Nothing (,)
553 (map Just $ splitDirectories base)
554 (map Just $ splitDirectories dir)
555 where collapse = foldr (</>) ""