@@ -3,47 +3,77 @@
33{-# LANGUAGE MultiParamTypeClasses #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TemplateHaskell #-}
76{-# LANGUAGE TupleSections #-}
7+{-# LANGUAGE QuasiQuotes #-}
88module Obelisk.Command.Run where
99
10−import Control.Applicative (liftA2)
10+import Control.Arrow ((&&&))
1111import Control.Exception (Exception, bracket)
12−import Control.Monad
12+import Control.Lens (ifor, (.~), (&))
13+import Control.Monad (filterM, unless, void)
1314import Control.Monad.Except (runExceptT, throwError)
1415import Control.Monad.IO.Class (liftIO)
1516import Control.Monad.Reader (MonadIO)
17+import Data.Coerce (coerce)
18+import Data.Default (def)
1619import Data.Either
17−import Data.Foldable (for_)
18−import qualified Data.List as L
20+import Data.Foldable (for_, toList)
1921import qualified Data.List.NonEmpty as NE
22+import Data.Map (Map)
23+import qualified Data.Map as Map
2024import Data.Maybe
25+import qualified Data.Set as Set
26+import Data.Text (Text)
2127import qualified Data.Text as T
28+import Data.Time.Clock (getCurrentTime)
29+import Data.Time.Format (formatTime, defaultTimeLocale)
30+import Data.Traversable (for)
31+import Debug.Trace (trace)
2232import Distribution.Compiler (CompilerFlavor(..))
2333import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
2434import Distribution.Parsec.ParseResult (runParseResult)
25−import Distribution.Pretty
35+import qualified Distribution.System as Dist
2636import Distribution.Types.BuildInfo
2737import Distribution.Types.CondTree
2838import Distribution.Types.GenericPackageDescription
2939import Distribution.Types.Library
3040import Distribution.Utils.Generic
41+import qualified Distribution.Parsec.Common as Dist
3142import qualified Hpack.Config as Hpack
3243import qualified Hpack.Render as Hpack
3344import qualified Hpack.Yaml as Hpack
3445import Language.Haskell.Extension
3546import Network.Socket hiding (Debug)
3647import System.Directory
48+import System.Environment (getExecutablePath)
3749import System.FilePath
50+import qualified System.Info
3851import System.IO.Temp (withSystemTempDirectory)
39−import System.Which (staticWhich)
4052
41−import Obelisk.App (MonadObelisk, ObeliskT)
42−import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)
43−import Obelisk.Command.Project (inProjectShell, withProjectRoot)
53+import Obelisk.App (MonadObelisk)
54+import Obelisk.CliApp (
55+ Severity (..),
56+ createProcess_,
57+ failWith,
58+ proc,
59+ putLog,
60+ readCreateProcessWithExitCode,
61+ readProcessAndLogStderr,
62+ setCwd,
63+ setDelegateCtlc,
64+ waitForProcess,
65+ withSpinner,
66+ )
67+import Obelisk.Command.Nix
68+import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot, findProjectAssets)
69+import Obelisk.Command.Thunk (attrCacheFileName)
70+import Obelisk.Command.Utils (findExePath, ghcidExePath)
4471
4572data CabalPackageInfo = CabalPackageInfo
46− { _cabalPackageInfo_packageRoot :: FilePath
73+ { _cabalPackageInfo_packageFile :: FilePath
74+ , _cabalPackageInfo_packageName :: T.Text
75+ , _cabalPackageInfo_packageRoot :: FilePath
76+ , _cabalPackageInfo_buildable :: Bool
4777 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
4878 -- ^ List of hs src dirs of the library component
4979 , _cabalPackageInfo_defaultExtensions :: [Extension]
@@ -54,108 +84,182 @@ data CabalPackageInfo = CabalPackageInfo
5484 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
5585 }
5686
57−-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
58−run :: ObeliskT IO ()
59−run = do
60− let nixPath = $(staticWhich "nix")
61− nixBuildPath = $(staticWhich "nix-build")
62− pkgs <- getLocalPkgs
63− withGhciScript pkgs $ \dotGhciPath -> do
87+-- | Used to signal to obelisk that it's being invoked as a preprocessor
88+preprocessorIdentifier :: String
89+preprocessorIdentifier = "__preprocessor-apply-packages"
90+
91+profile
92+ :: MonadObelisk m
93+ => String
94+ -> [String]
95+ -> m ()
96+profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
97+ putLog Debug "Using profiled build of project."
98+
99+ outPath <- withSpinner "Building profiled executable" $
100+ fmap (T.unpack . T.strip) $ readProcessAndLogStderr Debug $ setCwd (Just root) $ nixCmdProc $
101+ NixCmd_Build $ def
102+ & nixBuildConfig_outLink .~ OutLink_None
103+ & nixCmdConfig_target .~ Target
104+ { _target_path = Just "."
105+ , _target_attr = Just "__unstable__.profiledObRun"
106+ , _target_expr = Nothing
107+ }
108+ assets <- findProjectAssets root
109+ putLog Debug $ "Assets impurely loaded from: " <> assets
110+ time <- liftIO getCurrentTime
111+ let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
112+ liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
113+ putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
114+ freePort <- getFreePort
115+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
116+ [ show freePort
117+ , T.unpack assets
118+ , profileBaseName
119+ , "+RTS"
120+ , "-po" <> profileBaseName
121+ ] <> rtsFlags
122+ <> [ "-RTS" ]
123+ void $ waitForProcess ph
124+
125+run
126+ :: MonadObelisk m
127+ => m ()
128+run = withProjectRoot "." $ \root -> do
129+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
130+ withGhciScript pkgs root $ \dotGhciPath -> do
64131 freePort <- getFreePort
65− assets <- withProjectRoot "." $ \root -> do
66− let importableRoot = if "/" `isInfixOf` root
67− then root
68− else "./" <> root
69− isDerivation <- readProcessAndLogStderr Debug $
70− proc nixPath
71− [ "eval"
72− , "-f"
73− , root
74− , "(let a = import " <> importableRoot <> " {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
75− , "--raw"
76− -- `--raw` is not available with old nix-instantiate. It drops quotation
77− -- marks and trailing newline, so is very convenient for shelling out.
78− ]
79− -- Check whether the impure static files are a derivation (and so must be built)
80− if isDerivation == "1"
81− then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option
82− proc nixBuildPath
83− [ "--no-out-link"
84− , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"
85− ]
86− else readProcessAndLogStderr Debug $
87− proc nixPath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
132+ assets <- findProjectAssets root
88133 putLog Debug $ "Assets impurely loaded from: " <> assets
89− runGhcid dotGhciPath $ Just $ unwords
134+ runGhcid root True dotGhciPath pkgs $ Just $ unwords
90135 [ "Obelisk.Run.run"
91136 , show freePort
92− , "(runServeAsset " ++ show assets ++ ")"
137+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
93138 , "Backend.backend"
94139 , "Frontend.frontend"
95140 ]
96141
97142runRepl :: MonadObelisk m => m ()
98−runRepl = do
99− pkgs <- getLocalPkgs
100− withGhciScript pkgs $ \dotGhciPath -> do
101− runGhciRepl dotGhciPath
143+runRepl = withProjectRoot "." $ \root -> do
144+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
145+ withGhciScript pkgs "." $ \dotGhciPath ->
146+ runGhciRepl root pkgs dotGhciPath
102147
103148runWatch :: MonadObelisk m => m ()
104−runWatch = do
105− pkgs <- getLocalPkgs
106− withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
149+runWatch = withProjectRoot "." $ \root -> do
150+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
151+ withGhciScript pkgs root $ \dotGhciPath ->
152+ runGhcid root True dotGhciPath pkgs Nothing
153+
154+-- | Relative paths to local packages of an obelisk project.
155+--
156+-- These are a combination of the obelisk predefined local packages,
157+-- and any packages that the user has set with the @packages@ argument
158+-- to the Nix @project@ function.
159+getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
160+getLocalPkgs root = do
161+ obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
162+
163+ -- We do not want to find packages that are embedded inside other obelisk projects, unless that
164+ -- obelisk project is our own.
165+ let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
166+ fmap (map (makeRelative ".")) $ runFind $
167+ ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
168+ <> concat [["-not", "-path", p </> "*"] | p <- (toImplDir "*" </> attrCacheFileName) : exclusions]
169+ where
170+ runFind args = do
171+ (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
172+ putLog Debug $ T.strip $ T.pack err
173+ pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
107174
108175data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
109176 deriving (Eq, Ord, Show)
110177instance Exception GuessPackageFileError
111178
179+newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
180+newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
181+
112182-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
113183guessCabalPackageFile
114− :: MonadIO m
115− => FilePath -- ^ Directory to search for cabal package
116− -> m (Either GuessPackageFileError (Either FilePath FilePath))
117− -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.
118−guessCabalPackageFile dir = do
119− candidates <- liftIO $
120− filterM (doesFileExist . (dir </>))
121− =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))
122− <$> listDirectory dir
123− pure $ case L.partition (== Hpack.packageConfig) candidates of
124− ([hpack], _) -> Right $ Left hpack
125− ([], [cabal]) -> Right $ Right cabal
126− ([], []) -> Left GuessPackageFileError_NotFound
127− (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals
184+ :: (MonadIO m)
185+ => FilePath -- ^ Directory or path to search for cabal package
186+ -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
187+guessCabalPackageFile pkg = do
188+ liftIO (doesDirectoryExist pkg) >>= \case
189+ False -> case cabalOrHpackFile pkg of
190+ (Just hpack@(Right _)) -> pure $ Right hpack
191+ (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
192+ -- If the cabal file has a sibling hpack file, we use that instead
193+ -- since running hpack often generates a sibling cabal file
194+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
195+ hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
196+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
197+ Nothing -> pure $ Left GuessPackageFileError_NotFound
198+ True -> do
199+ candidates <- liftIO $
200+ filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
201+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
202+ pure $ case partitionEithers candidates of
203+ ([hpack], _) -> Right $ Left hpack
204+ ([], [cabal]) -> Right $ Right cabal
205+ ([], []) -> Left GuessPackageFileError_NotFound
206+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
128207
129−-- | Relative paths to local packages of an obelisk project
130−-- TODO a way to query this
131−getLocalPkgs :: Applicative f => f [FilePath]
132−getLocalPkgs = pure ["backend", "common", "frontend"]
208+cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
209+cabalOrHpackFile = \case
210+ x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
211+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
212+ | otherwise -> Nothing
133213
214+-- | Parses the cabal package in a given directory.
215+-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
134216parseCabalPackage
135− :: (MonadObelisk m)
136− => FilePath -- ^ package directory
217+ :: MonadObelisk m
218+ => FilePath -- ^ Package directory
137219 -> m (Maybe CabalPackageInfo)
138−parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do
139− (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case
140− Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir
141− Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir
142− Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)
143− Right (Left hpackFileName) -> do
220+parseCabalPackage dir = parseCabalPackage' dir >>= \case
221+ Left err -> Nothing <$ putLog Error err
222+ Right (warnings, pkgInfo) -> do
223+ for_ warnings $ putLog Warning . T.pack . show
224+ pure $ Just pkgInfo
225+
226+-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
227+parseCabalPackage'
228+ :: (MonadIO m)
229+ => FilePath -- ^ Package directory
230+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
231+parseCabalPackage' pkg = runExceptT $ do
232+ (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
233+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
234+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
235+ Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
236+ Right (Right (HPackFilePath file)) -> do
144237 let
145− file = dir </> hpackFileName
146238 decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
147239 liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
148240 Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
149− Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)
241+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
150242
151− let (warnings, result) = runParseResult $ parseGenericPackageDescription $
152− toUTF8BS cabalContents
153− for_ warnings $ putLog Warning . T.pack . show
243+ let
244+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
245+ osConfVar = case System.Info.os of
246+ "linux" -> Just Dist.Linux
247+ "darwin" -> Just Dist.OSX
248+ _ -> trace "Unrecgonized System.Info.os" Nothing
249+ archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
250+ evalConfVar v = Right $ case v of
251+ OS osVar -> Just osVar == osConfVar
252+ Arch archVar -> Just archVar == archConfVar
253+ Impl GHC _ -> True -- TODO: Actually check version range
254+ _ -> False
154255 case condLibrary <$> result of
155256 Right (Just condLib) -> do
156− let (_, lib) = simplifyCondTree (const $ pure True) condLib
157− pure $ CabalPackageInfo
158− { _cabalPackageInfo_packageRoot = dir
257+ let (_, lib) = simplifyCondTree evalConfVar condLib
258+ pure $ (warnings,) $ CabalPackageInfo
259+ { _cabalPackageInfo_packageName = T.pack packageName
260+ , _cabalPackageInfo_packageFile = packageFile
261+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile
262+ , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
159263 , _cabalPackageInfo_sourceDirs =
160264 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
161265 , _cabalPackageInfo_defaultExtensions =
@@ -168,45 +272,60 @@ parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< r
168272 Left (_, errors) ->
169273 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
170274
275+parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
276+parsePackagesOrFail dirs = do
277+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
278+ flip fmap (parseCabalPackage dir) $ \case
279+ Just packageInfo
280+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
281+ _ -> Left dir
282+
283+ let packagesByName = Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
284+ unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
285+ p NE.:| [] -> pure p -- No ambiguity here
286+ p NE.:| _ -> do
287+ putLog Warning $ T.pack $
288+ "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "
289+ <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)
290+ <> "; Picking " <> _cabalPackageInfo_packageFile p
291+ pure p
292+
293+ packageInfos <- case NE.nonEmpty $ toList unambiguous of
294+ Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
295+ Just xs -> pure xs
296+
297+ unless (null pkgDirErrs) $
298+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
299+
300+ pure packageInfos
301+
302+packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
303+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
304+
171305-- | Create ghci configuration to load the given packages
172306withGhciScript
173307 :: MonadObelisk m
174− => [FilePath] -- ^ List of packages to load into ghci
308+ => [CabalPackageInfo] -- ^ List of packages to load into ghci
309+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
175310 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
176311 -> m ()
177−withGhciScript dirs f = do
178− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do
179− flip fmap (parseCabalPackage dir) $ \case
180− Nothing -> Left dir
181− Just packageInfo -> Right packageInfo
182−
183− when (null packageInfos) $
184− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs
185− unless (null pkgDirErrs) $
186− putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
187−
188− let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
189− languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
190− -- NOTE when no default-language is present cabal sets Haskell98
191− language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
192− extensionsLine = if extensions == mempty
193− then ""
194− else ":set " <> unwords (("-X" <>) . prettyShow <$> extensions)
195− ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $
196− packageInfos >>= _cabalPackageInfo_compilerOptions
197− dotGhci = unlines
198− [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
199− , case ghcOptions of
200− [] -> ""
201− xs -> ":set " <> unwords xs
202− , extensionsLine
203− , ":set " <> unwords (("-X" <>) . prettyShow <$> language)
204− , ":load Backend Frontend"
205− , "import Obelisk.Run"
206− , "import qualified Frontend"
207− , "import qualified Backend"
208− ]
209− warnDifferentLanguages language
312+withGhciScript packageInfos pathBase f = do
313+ selfExe <- liftIO getExecutablePath
314+ let
315+ packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
316+ modulesToLoad = mconcat
317+ [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
318+ , [ "Backend" | "backend" `Set.member` packageNames ]
319+ , [ "Frontend" | "frontend" `Set.member` packageNames ]
320+ ]
321+ dotGhci = unlines
322+ -- TODO: Shell escape
323+ [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
324+ , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
325+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
326+ , "import qualified Obelisk.Run"
327+ , "import qualified Frontend"
328+ , "import qualified Backend" ]
210329 withSystemTempDirectory "ob-ghci" $ \fp -> do
211330 let dotGhciPath = fp </> ".ghci"
212331 liftIO $ writeFile dotGhciPath dotGhci
@@ -214,35 +333,44 @@ withGhciScript dirs f = do
214333
215334 where
216335 rootedSourceDirs pkg = NE.toList $
217− (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
218−
219−warnDifferentLanguages :: MonadObelisk m => [Language] -> m ()
220−warnDifferentLanguages (_:_:_) = putLog Warning "Different languages detected across packages which may result in errors when loading the repl"
221−warnDifferentLanguages _ = return ()
336+ makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
222337
223338-- | Run ghci repl
224339runGhciRepl
225340 :: MonadObelisk m
226− => FilePath -- ^ Path to .ghci
341+ => FilePath -- ^ Path to project root
342+ -> [CabalPackageInfo]
343+ -> FilePath -- ^ Path to .ghci
227344 -> m ()
228−runGhciRepl dotGhci = inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci
345+runGhciRepl root packages dotGhci =
346+ -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
347+ -- ghc that is provided by the shell in the user's project.
348+ nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
229349
230350-- | Run ghcid
231351runGhcid
232352 :: MonadObelisk m
233− => FilePath -- ^ Path to .ghci
353+ => FilePath -- ^ Path to project root
354+ -> Bool -- ^ Should we chdir to root when running this process?
355+ -> FilePath -- ^ Path to .ghci
356+ -> [CabalPackageInfo]
234357 -> Maybe String -- ^ Optional command to run at every reload
235358 -> m ()
236−runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
359+runGhcid root chdirToRoot dotGhci packages mcmd =
360+ nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
237361 where
238362 opts =
239363 [ "-W"
240− --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
241− , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints " <> makeBaseGhciOptions dotGhci <> "' "
242− , "--reload=config"
364+ , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
243365 , "--outputfile=ghcid-output.txt"
244− ] <> testCmd
245− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
366+ ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
367+ <> map (\x -> "--restart='" <> x <> "'") restartFiles
368+ <> testCmd
369+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
370+
371+ adjustRoot x = if chdirToRoot then makeRelative root x else x
372+ reloadFiles = map adjustRoot [root </> "config"]
373+ restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
246374
247375makeBaseGhciOptions :: FilePath -> String
248376makeBaseGhciOptions dotGhci =