@@ -1,27 +1,41 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
14{-# LANGUAGE FlexibleContexts #-}
25{-# LANGUAGE LambdaCase #-}
36{-# LANGUAGE MultiParamTypeClasses #-}
47{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE QuasiQuotes #-}
59{-# LANGUAGE ScopedTypeVariables #-}
610{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE ViewPatterns #-}
712module Obelisk.Command.Run where
813
914import Control.Arrow ((&&&))
1015import Control.Exception (Exception, bracket)
1116import Control.Lens (ifor, (.~), (&))
12−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
1318import Control.Monad.Except (runExceptT, throwError)
1419import Control.Monad.IO.Class (liftIO)
1520import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
1623import Data.Coerce (coerce)
1724import Data.Default (def)
18−import Data.Either
19−import Data.Foldable (for_, toList)
25+import Data.Either (partitionEithers)
26+import Data.Foldable (fold, for_, toList)
27+import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
29+import Data.List.NonEmpty (NonEmpty)
2030import qualified Data.List.NonEmpty as NE
2131import Data.Map (Map)
2232import qualified Data.Map as Map
23−import Data.Maybe
33+import qualified Data.Map.Monoidal as MMap
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
36+import Data.Set (Set)
2437import qualified Data.Set as Set
38+import Data.String.Here.Interpolated (i)
2539import Data.Text (Text)
2640import qualified Data.Text as T
2741import Data.Time.Clock (getCurrentTime)
@@ -32,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
3246import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
3347import Distribution.Parsec.ParseResult (runParseResult)
3448import qualified Distribution.System as Dist
35−import Distribution.Types.BuildInfo
36−import Distribution.Types.CondTree
37−import Distribution.Types.GenericPackageDescription
38−import Distribution.Types.Library
39−import Distribution.Utils.Generic
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
50+import Distribution.Types.CondTree (simplifyCondTree)
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
52+import Distribution.Types.Library (libBuildInfo)
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
4054import qualified Distribution.Parsec.Common as Dist
4155import qualified Hpack.Config as Hpack
4256import qualified Hpack.Render as Hpack
4357import qualified Hpack.Yaml as Hpack
44−import Language.Haskell.Extension
45−import Network.Socket hiding (Debug)
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
4660import System.Directory
4761import System.Environment (getExecutablePath)
4862import System.FilePath
@@ -52,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
5266import Obelisk.App (MonadObelisk)
5367import Obelisk.CliApp (
5468 Severity (..),
55− createProcess_,
5669 failWith,
5770 proc,
5871 putLog,
5972 readCreateProcessWithExitCode,
6073 readProcessAndLogStderr,
74+ runProcess_,
6175 setCwd,
6276 setDelegateCtlc,
63− waitForProcess,
6477 withSpinner,
6578 )
6679import Obelisk.Command.Nix
67−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
6881import Obelisk.Command.Thunk (attrCacheFileName)
6982import Obelisk.Command.Utils (findExePath, ghcidExePath)
7083
@@ -81,8 +94,35 @@ data CabalPackageInfo = CabalPackageInfo
8194 -- ^ List of globally set languages of the library component
8295 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
8396 -- ^ 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)
8499 }
85100
101+-- | 'Bool' with a better name for its purpose.
102+data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
103+
104+textInterpret :: Interpret -> Text
105+textInterpret = \case
106+ Interpret_Interpret -> "Interpret"
107+ Interpret_NoInterpret -> "NoInterpret"
108+
109+-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
110+data PathTree a = PathTree_Node
111+ (Maybe a) -- An optional leaf at this point in the tree
112+ (Map FilePath (PathTree a)) -- Branches to deeper leaves
113+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
114+
115+-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116+drawPathTree :: (a -> Text) -> PathTree a -> Text
117+drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
118+ where
119+ annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
120+ goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
121+ goForest [] = []
122+ goForest [tree] = shift "└─ " " " (goTree tree)
123+ goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
124+ shift first other = zipWith (<>) (first : repeat other)
125+
86126-- | Used to signal to obelisk that it's being invoked as a preprocessor
87127preprocessorIdentifier :: String
88128preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -111,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
111151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
112152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
113153 freePort <- getFreePort
114− (_, _, _, 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") $
115155 [ show freePort
116156 , T.unpack assets
117157 , profileBaseName
@@ -119,18 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
119159 , "-po" <> profileBaseName
120160 ] <> rtsFlags
121161 <> [ "-RTS" ]
122− void $ waitForProcess ph
123162
124−run
125− :: MonadObelisk m
126− => m ()
127−run = withProjectRoot "." $ \root -> do
128− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
129− withGhciScript pkgs root $ \dotGhciPath -> do
130− freePort <- getFreePort
131− assets <- findProjectAssets root
132− putLog Debug $ "Assets impurely loaded from: " <> assets
133− runGhcid root True dotGhciPath pkgs $ Just $ unwords
163+run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164+run 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
134172 [ "Obelisk.Run.run"
135173 , show freePort
136174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -138,39 +176,87 @@ run = withProjectRoot "." $ \root -> do
138176 , "Frontend.frontend"
139177 ]
140178
141−runRepl :: MonadObelisk m => m ()
142−runRepl = withProjectRoot "." $ \root -> do
143− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
144− withGhciScript pkgs "." $ \dotGhciPath ->
145− runGhciRepl root pkgs dotGhciPath
179+runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180+runRepl root interpretPaths = do
181+ pkgs <- getParsedLocalPkgs root interpretPaths
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
185+
186+runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187+runWatch 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
192+
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194+exportGhciConfig useRelativePaths root interpretPaths = do
195+ pkgs <- getParsedLocalPkgs root interpretPaths
196+ getGhciSessionSettings pkgs "." useRelativePaths
197+
198+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
199+nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200+ pkgs <- getParsedLocalPkgs root interpretPaths
201+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
146202
147−runWatch :: MonadObelisk m => m ()
148−runWatch = withProjectRoot "." $ \root -> do
149− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
150− withGhciScript pkgs root $ \dotGhciPath ->
151− runGhcid root True dotGhciPath pkgs Nothing
203+-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
204+getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
205+getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
152206
153207-- | Relative paths to local packages of an obelisk project.
154208--
155209-- These are a combination of the obelisk predefined local packages,
156210-- and any packages that the user has set with the @packages@ argument
157211-- to the Nix @project@ function.
158−getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
159−getLocalPkgs root = do
160− obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
212+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
213+getLocalPkgs 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"]
161216
162217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
163218 -- obelisk project is our own.
164− let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
165− fmap (map (makeRelative ".")) $ runFind $
166− ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
167− <> concat [["-not", "-path", p </> "*"] | p <- ("*" </> attrCacheFileName) : exclusions]
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
223+
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]
168229 where
169230 runFind args = do
170231 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
171232 putLog Debug $ T.strip $ T.pack err
172233 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
173234
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.
238+calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
239+calcIntepretFinds 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)
246+
247+-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
248+foldPathTreeFor
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
255+foldPathTreeFor 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
259+
174260data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
175261 deriving (Eq, Ord, Show)
176262instance Exception GuessPackageFileError
@@ -218,15 +304,16 @@ parseCabalPackage
218304 -> m (Maybe CabalPackageInfo)
219305parseCabalPackage dir = parseCabalPackage' dir >>= \case
220306 Left err -> Nothing <$ putLog Error err
221− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
222308 for_ warnings $ putLog Warning . T.pack . show
223309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
224311
225312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
226313parseCabalPackage'
227314 :: (MonadIO m)
228315 => FilePath -- ^ Package directory
229− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
230317parseCabalPackage' pkg = runExceptT $ do
231318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
232319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -254,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
254341 case condLibrary <$> result of
255342 Right (Just condLib) -> do
256343 let (_, lib) = simplifyCondTree evalConfVar condLib
257− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
258345 { _cabalPackageInfo_packageName = T.pack packageName
259346 , _cabalPackageInfo_packageFile = packageFile
260347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -266,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
266353 , _cabalPackageInfo_defaultLanguage =
267354 defaultLanguage $ libBuildInfo lib
268355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
269357 }
270− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
271359 Left (_, errors) ->
272360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
273361
274−parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
275−parsePackagesOrFail dirs = do
276− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
362+parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
363+parsePackagesOrFail dirs' = do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
277365 flip fmap (parseCabalPackage dir) $ \case
278366 Just packageInfo
279− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
280− _ -> Left dir
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
281369
282370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
283371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -285,108 +373,182 @@ parsePackagesOrFail dirs = do
285373 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
286374 p NE.:| [] -> pure p -- No ambiguity here
287375 p NE.:| _ -> do
288− putLog Warning $ T.pack $
289− "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "
290− <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)
291− <> "; Picking " <> _cabalPackageInfo_packageFile p
376+ let chosenText = " [Chosen] "
377+ prefix p'
378+ | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText
379+ | otherwise = T.map (const ' ') chosenText
380+ putLog Warning $ T.unlines $
381+ "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "
382+ : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)
292383 pure p
293384
294385 packageInfos <- case NE.nonEmpty $ toList unambiguous of
295− Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
386+ Nothing -> failWith $ T.pack $
387+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
296388 Just xs -> pure xs
297389
298− unless (null pkgDirErrs) $
299− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
300−
301390 pure packageInfos
391+ where
392+ dirs = toList dirs'
302393
303−packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
304−packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
394+packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
396+
397+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
398+withGhciScriptArgs
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
402+ -> m ()
403+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
404+ where
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
410+ ]
305411
306412-- | Create ghci configuration to load the given packages
307413withGhciScript
308− :: MonadObelisk m
309− => [CabalPackageInfo] -- ^ List of packages to load into ghci
310− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
414+ :: (MonadObelisk m, Foldable f)
415+ => [String] -- ^ Commands to prefix to file
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
311417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
312418 -> m ()
313−withGhciScript packageInfos pathBase f = do
314− selfExe <- liftIO getExecutablePath
315− let
419+withGhciScript preCommands (toList -> packageInfos) f =
420+ withSystemTempDirectory "ob-ghci" $ \fp -> do
421+ let dotGhciPath = fp </> ".ghci"
422+ liftIO $ writeFile dotGhciPath dotGhci
423+ f dotGhciPath
424+ where
316425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
317426 modulesToLoad = mconcat
318427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
319428 , [ "Backend" | "backend" `Set.member` packageNames ]
320429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
321430 ]
322− dotGhci = unlines
323− -- TODO: Shell escape
324− [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
325− , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
326− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
431+ dotGhci = unlines $
432+ preCommands <>
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
327434 , "import qualified Obelisk.Run"
328435 , "import qualified Frontend"
329− , "import qualified Backend" ]
330− withSystemTempDirectory "ob-ghci" $ \fp -> do
331− let dotGhciPath = fp </> ".ghci"
332− liftIO $ writeFile dotGhciPath dotGhci
333− f dotGhciPath
436+ , "import qualified Backend"
437+ ]
438+
439+-- | Builds a list of options to pass to ghci or set in .ghci file that configures
440+-- the preprocessor and source includes.
441+getGhciSessionSettings
442+ :: (MonadObelisk m, Foldable f)
443+ => f CabalPackageInfo -- ^ List of packages to load into ghci
444+ -> FilePath -- ^ All paths will be relative to this path
445+ -> Bool -- ^ Use relative paths
446+ -> m [String]
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'.
451+ selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
452+ canonicalPathBase <- liftIO $ canonicalizePath pathBase
453+
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)
334458
459+ pure
460+ $ baseGhciOptions
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
462+ <> concatMap (\p -> ["-optF", p]) pkgFiles
463+ <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
335464 where
336− rootedSourceDirs pkg = NE.toList $
337− makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
465+ relativeTo' = if useRelativePaths then relativeTo else const
466+
467+baseGhciOptions :: [String]
468+baseGhciOptions =
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
472+ ]
338473
339474-- | Run ghci repl
340475runGhciRepl
341− :: MonadObelisk m
476+ :: (MonadObelisk m, Foldable f)
342477 => FilePath -- ^ Path to project root
343− -> [CabalPackageInfo]
344− -> FilePath -- ^ Path to .ghci
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
479+ -> [String] -- ^ GHCi arguments
345480 -> m ()
346−runGhciRepl root packages dotGhci =
481+runGhciRepl root (toList -> packages) ghciArgs =
347482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
348483 -- ghc that is provided by the shell in the user's project.
349− nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
484+ nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
350486
351487-- | Run ghcid
352488runGhcid
353− :: MonadObelisk m
489+ :: (MonadObelisk m, Foldable f)
354490 => FilePath -- ^ Path to project root
355491 -> Bool -- ^ Should we chdir to root when running this process?
356− -> FilePath -- ^ Path to .ghci
357− -> [CabalPackageInfo]
492+ -> [String] -- ^ GHCi arguments
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
358494 -> Maybe String -- ^ Optional command to run at every reload
359495 -> m ()
360−runGhcid root chdirToRoot dotGhci packages mcmd =
361− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
362499 where
363− opts =
364− [ "-W"
365− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
366− , "--outputfile=ghcid-output.txt"
367− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
368− <> map (\x -> "--restart='" <> x <> "'") restartFiles
369− <> testCmd
370− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
371−
500+ opts = concat
501+ [ ["-W"]
502+ , ["--outputfile=ghcid-output.txt"]
503+ , map (\x -> "--reload=" <> x) reloadFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
507+ ]
372508 adjustRoot x = if chdirToRoot then makeRelative root x else x
373509 reloadFiles = map adjustRoot [root </> "config"]
374510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
375511
376−makeBaseGhciOptions :: FilePath -> String
377−makeBaseGhciOptions dotGhci =
378− unwords
379− [ "-no-user-package-db"
380− , "-package-env -"
381− , "-ghci-script " <> dotGhci
382− ]
383−
384−getFreePort :: MonadIO m => m PortNumber
385−getFreePort = liftIO $ withSocketsDo $ do
386− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
387− bracket (open addr) close socketPort
512+getFreePort :: MonadIO m => m Socket.PortNumber
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
515+ bracket (open addr) Socket.close Socket.socketPort
388516 where
389517 open addr = do
390− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
391− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
392520 return sock
521+
522+
523+-- | Convert a 'FilePath' into a 'PathTree'.
524+pathToTree :: a -> FilePath -> PathTree a
525+pathToTree a p = go $ splitDirectories p
526+ where
527+ go [] = PathTree_Node (Just a) mempty
528+ go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
529+
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
536+
537+-- | Makes the first absolute path relative to the second absolute path.
538+--
539+-- Both input paths MUST be absolute.
540+--
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
546+relativeTo dir base
547+ = bifoldr1 (</>)
548+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
549+ $ unzip
550+ $ dropWhile (\(a,b) -> a == b)
551+ $ zipDefaultWith Nothing Nothing (,)
552+ (map Just $ splitDirectories base)
553+ (map Just $ splitDirectories dir)
554+ where collapse = foldr (</>) ""