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