@@ -1,41 +1,27 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE QuasiQuotes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE ViewPatterns #-}
12module Obelisk.Command.Run where
7module Obelisk.Command.Run where
14import Control.Arrow ((&&&))
9import Control.Arrow ((&&&))
15import Control.Exception (Exception, bracket)
10import Control.Exception (Exception, bracket)
16import Control.Lens (ifor, (.~), (&))
11import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM)
12+import Control.Monad (filterM, unless, void)
18import Control.Monad.Except (runExceptT, throwError)
13import Control.Monad.Except (runExceptT, throwError)
19import Control.Monad.IO.Class (liftIO)
14import Control.Monad.IO.Class (liftIO)
20import Control.Monad.Reader (MonadIO)
15import Control.Monad.Reader (MonadIO)
21−import Data.Bifoldable (bifoldr1)
22−import Data.Bifunctor (bimap)
23import Data.Coerce (coerce)
16import Data.Coerce (coerce)
24import Data.Default (def)
17import Data.Default (def)
25−import Data.Either (partitionEithers)
18+import Data.Either
26−import Data.Foldable (fold, for_, toList)
19+import Data.Foldable (for_, toList)
27−import Data.Functor.Identity (runIdentity)
28−import Data.List (intercalate)
29−import Data.List.NonEmpty (NonEmpty)
30import qualified Data.List.NonEmpty as NE
20import qualified Data.List.NonEmpty as NE
31import Data.Map (Map)
21import Data.Map (Map)
32import qualified Data.Map as Map
22import qualified Data.Map as Map
33−import qualified Data.Map.Monoidal as MMap
23+import Data.Maybe
34−import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35−import Data.Ord (comparing)
37import qualified Data.Set as Set
24import qualified Data.Set as Set
38−import Data.String.Here.Interpolated (i)
39import Data.Text (Text)
25import Data.Text (Text)
40import qualified Data.Text as T
26import qualified Data.Text as T
41import Data.Time.Clock (getCurrentTime)
27import Data.Time.Clock (getCurrentTime)
@@ -46,17 +32,17 @@ import Distribution.Compiler (CompilerFlavor(..))
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
32import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
47import Distribution.Parsec.ParseResult (runParseResult)
33import Distribution.Parsec.ParseResult (runParseResult)
48import qualified Distribution.System as Dist
34import qualified Distribution.System as Dist
49−import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
35+import Distribution.Types.BuildInfo
50−import Distribution.Types.CondTree (simplifyCondTree)
36+import Distribution.Types.CondTree
51−import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
37+import Distribution.Types.GenericPackageDescription
52−import Distribution.Types.Library (libBuildInfo)
38+import Distribution.Types.Library
53−import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
39+import Distribution.Utils.Generic
54import qualified Distribution.Parsec.Common as Dist
40import qualified Distribution.Parsec.Common as Dist
55import qualified Hpack.Config as Hpack
41import qualified Hpack.Config as Hpack
56import qualified Hpack.Render as Hpack
42import qualified Hpack.Render as Hpack
57import qualified Hpack.Yaml as Hpack
43import qualified Hpack.Yaml as Hpack
58−import Language.Haskell.Extension (Extension, Language)
44+import Language.Haskell.Extension
59−import qualified Network.Socket as Socket
45+import Network.Socket hiding (Debug)
60import System.Directory
46import System.Directory
61import System.Environment (getExecutablePath)
47import System.Environment (getExecutablePath)
62import System.FilePath
48import System.FilePath
@@ -66,18 +52,19 @@ import System.IO.Temp (withSystemTempDirectory)
66import Obelisk.App (MonadObelisk)
52import Obelisk.App (MonadObelisk)
67import Obelisk.CliApp (
53import Obelisk.CliApp (
68 Severity (..),
54 Severity (..),
72 readCreateProcessWithExitCode,
59 readCreateProcessWithExitCode,
73 readProcessAndLogStderr,
60 readProcessAndLogStderr,
76 setDelegateCtlc,
62 setDelegateCtlc,
77 withSpinner,
64 withSpinner,
79import Obelisk.Command.Nix
66import Obelisk.Command.Nix
80−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
67+import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot, findProjectAssets)
81import Obelisk.Command.Thunk (attrCacheFileName)
68import Obelisk.Command.Thunk (attrCacheFileName)
82import Obelisk.Command.Utils (findExePath, ghcidExePath)
69import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -94,35 +81,8 @@ data CabalPackageInfo = CabalPackageInfo
94 -- ^ List of globally set languages of the library component
81 -- ^ List of globally set languages of the library component
95 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
82 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
96 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
83 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
97− , _cabalPackageInfo_cppOptions :: [String]
98− -- ^ List of CPP (C Preprocessor) options (e.g. the "cpp-options" field of the cabal file)
101−-- | 'Bool' with a better name for its purpose.
102−data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
104−textInterpret :: Interpret -> Text
105−textInterpret = \case
106− Interpret_Interpret -> "Interpret"
107− Interpret_NoInterpret -> "NoInterpret"
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)
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)
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)
122− goForest [tree] = shift "└─ " " " (goTree tree)
123− goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
124− shift first other = zipWith (<>) (first : repeat other)
126-- | Used to signal to obelisk that it's being invoked as a preprocessor
86-- | Used to signal to obelisk that it's being invoked as a preprocessor
127preprocessorIdentifier :: String
87preprocessorIdentifier :: String
128preprocessorIdentifier = "__preprocessor-apply-packages"
88preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -151,7 +111,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
111 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
112 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153 freePort <- getFreePort
113 freePort <- getFreePort
154− runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
114+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155 [ show freePort
115 [ show freePort
156 , T.unpack assets
116 , T.unpack assets
157 , profileBaseName
117 , profileBaseName
@@ -159,16 +119,18 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159 , "-po" <> profileBaseName
119 , "-po" <> profileBaseName
160 ] <> rtsFlags
120 ] <> rtsFlags
161 <> [ "-RTS" ]
121 <> [ "-RTS" ]
122+ void $ waitForProcess ph
163−run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
125+ :: MonadObelisk m
164−run root interpretPaths = do
126+ => m ()
165− pkgs <- getParsedLocalPkgs root interpretPaths
127+run = withProjectRoot "." $ \root -> do
128+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
129+ withGhciScript pkgs root $ \dotGhciPath -> do
130+ freePort <- getFreePort
166− assets <- findProjectAssets root
131+ assets <- findProjectAssets root
167− putLog Debug $ "Assets impurely loaded from: " <> assets
132+ 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
133+ runGhcid root True dotGhciPath pkgs $ Just $ unwords
172 [ "Obelisk.Run.run"
134 [ "Obelisk.Run.run"
173 , show freePort
135 , show freePort
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
136 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -176,87 +138,39 @@ run root interpretPaths = do
176 , "Frontend.frontend"
138 , "Frontend.frontend"
179−runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
141+runRepl :: MonadObelisk m => m ()
180−runRepl root interpretPaths = do
142+runRepl = withProjectRoot "." $ \root -> do
181− pkgs <- getParsedLocalPkgs root interpretPaths
143+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
182− ghciArgs <- getGhciSessionSettings pkgs "." True
144+ withGhciScript pkgs "." $ \dotGhciPath ->
183− withGhciScriptArgs pkgs $ \dotGhciArgs ->
184− runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
145+ runGhciRepl root pkgs dotGhciPath
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
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
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
203−-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
147+runWatch :: MonadObelisk m => m ()
204−getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
148+runWatch = withProjectRoot "." $ \root -> do
205−getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
149+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
150+ withGhciScript pkgs root $ \dotGhciPath ->
151+ runGhcid root True dotGhciPath pkgs Nothing
207-- | Relative paths to local packages of an obelisk project.
153-- | Relative paths to local packages of an obelisk project.
209-- These are a combination of the obelisk predefined local packages,
155-- These are a combination of the obelisk predefined local packages,
210-- and any packages that the user has set with the @packages@ argument
156-- and any packages that the user has set with the @packages@ argument
211-- to the Nix @project@ function.
157-- to the Nix @project@ function.
212−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
158+getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
213−getLocalPkgs root interpretPaths = do
159+getLocalPkgs root = 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"]
160+ obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
162 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
218 -- obelisk project is our own.
163 -- obelisk project is our own.
219− obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
220− filter (/= root) $ map takeDirectory obeliskPackagePaths
164+ let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
221− putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
165+ fmap (map (makeRelative ".")) $ runFind $
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"]
166+ ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
228− <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
167+ <> concat [["-not", "-path", p </> "*"] | p <- (toImplDir "*" </> attrCacheFileName) : exclusions]
230 runFind args = do
169 runFind args = do
231 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
170 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
232 putLog Debug $ T.strip $ T.pack err
171 putLog Debug $ T.strip $ T.pack err
233 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
172 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.
238−calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
239−calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
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.
249− :: forall m a b. (Applicative m, Monoid b)
253− -> (FilePath -> PathTree a -> 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
260data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
174data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
261 deriving (Eq, Ord, Show)
175 deriving (Eq, Ord, Show)
262instance Exception GuessPackageFileError
176instance Exception GuessPackageFileError
@@ -304,16 +218,15 @@ parseCabalPackage
304 -> m (Maybe CabalPackageInfo)
218 -> m (Maybe CabalPackageInfo)
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
219parseCabalPackage dir = parseCabalPackage' dir >>= \case
306 Left err -> Nothing <$ putLog Error err
220 Left err -> Nothing <$ putLog Error err
307− Right (Just (warnings, pkgInfo)) -> do
221+ Right (warnings, pkgInfo) -> do
308 for_ warnings $ putLog Warning . T.pack . show
222 for_ warnings $ putLog Warning . T.pack . show
309 pure $ Just pkgInfo
223 pure $ Just pkgInfo
310− Right Nothing -> pure Nothing
312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
225-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313parseCabalPackage'
226parseCabalPackage'
314 :: (MonadIO m)
227 :: (MonadIO m)
315 => FilePath -- ^ Package directory
228 => FilePath -- ^ Package directory
316− -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
229+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
317parseCabalPackage' pkg = runExceptT $ do
230parseCabalPackage' pkg = runExceptT $ do
318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
231 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
232 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -341,7 +254,7 @@ parseCabalPackage' pkg = runExceptT $ do
341 case condLibrary <$> result of
254 case condLibrary <$> result of
342 Right (Just condLib) -> do
255 Right (Just condLib) -> do
343 let (_, lib) = simplifyCondTree evalConfVar condLib
256 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ Just $ (warnings,) $ CabalPackageInfo
257+ pure $ (warnings,) $ CabalPackageInfo
345 { _cabalPackageInfo_packageName = T.pack packageName
258 { _cabalPackageInfo_packageName = T.pack packageName
346 , _cabalPackageInfo_packageFile = packageFile
259 , _cabalPackageInfo_packageFile = packageFile
347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
260 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -353,202 +266,125 @@ parseCabalPackage' pkg = runExceptT $ do
353 , _cabalPackageInfo_defaultLanguage =
266 , _cabalPackageInfo_defaultLanguage =
354 defaultLanguage $ libBuildInfo lib
267 defaultLanguage $ libBuildInfo lib
355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
268 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356− , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
358− Right Nothing -> pure Nothing
270+ Right Nothing -> throwError "Haskell package has no library component"
359 Left (_, errors) ->
271 Left (_, errors) ->
360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
272 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
362−parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
274+parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
363−parsePackagesOrFail dirs' = do
275+parsePackagesOrFail dirs = do
364− packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
276+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
365 flip fmap (parseCabalPackage dir) $ \case
277 flip fmap (parseCabalPackage dir) $ \case
366 Just packageInfo
278 Just packageInfo
367− | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
279+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
368− _ -> Nothing
280+ _ -> Left dir
370− -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371− let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
372− $ Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
282+ let packagesByName = Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
373 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
283 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
374 p NE.:| [] -> pure p -- No ambiguity here
284 p NE.:| [] -> pure p -- No ambiguity here
375 p NE.:| _ -> do
285 p NE.:| _ -> do
376− let chosenText = " [Chosen] "
378− | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText
379− | otherwise = T.map (const ' ') chosenText
380− putLog Warning $ T.unlines $
286+ putLog Warning $ T.pack $
381− "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "
287+ "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "
382− : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)
288+ <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)
289+ <> "; Picking " <> _cabalPackageInfo_packageFile p
385 packageInfos <- case NE.nonEmpty $ toList unambiguous of
292 packageInfos <- case NE.nonEmpty $ toList unambiguous of
386− Nothing -> failWith $ T.pack $
387− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
293+ Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
388 Just xs -> pure xs
294 Just xs -> pure xs
390− pure packageInfos
296+ unless (null pkgDirErrs) $
391− where
297+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
394−packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
299+ pure packageInfos
395−packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
397−-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
301+packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
398−withGhciScriptArgs
302+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
399− :: (MonadObelisk m, Foldable f)
400− => f CabalPackageInfo -- ^ List of packages to load into ghci
401− -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
403−withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
405− -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
406− -- is passed to the ghci session.
407− loadPreludeManually =
408− [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
409− , ":set -XImplicitPrelude" -- Turn the default setting on
412-- | Create ghci configuration to load the given packages
304-- | Create ghci configuration to load the given packages
413withGhciScript
305withGhciScript
414− :: (MonadObelisk m, Foldable f)
306+ :: MonadObelisk m
415− => [String] -- ^ Commands to prefix to file
416− -> f CabalPackageInfo -- ^ List of packages to load into ghci
307+ => [CabalPackageInfo] -- ^ List of packages to load into ghci
308+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
309 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
419−withGhciScript preCommands (toList -> packageInfos) f =
311+withGhciScript packageInfos pathBase f = do
420− withSystemTempDirectory "ob-ghci" $ \fp -> do
312+ selfExe <- liftIO getExecutablePath
421− let dotGhciPath = fp </> ".ghci"
313+ let
422− liftIO $ writeFile dotGhciPath dotGhci
425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
314 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
426 modulesToLoad = mconcat
315 modulesToLoad = mconcat
427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
316 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
428 , [ "Backend" | "backend" `Set.member` packageNames ]
317 , [ "Backend" | "backend" `Set.member` packageNames ]
429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
318 , [ "Frontend" | "frontend" `Set.member` packageNames ]
431− dotGhci = unlines $
320+ dotGhci = unlines
432− preCommands <>
321+ -- TODO: Shell escape
322+ [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
323+ , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
433− [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
324+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434 , "import qualified Obelisk.Run"
325 , "import qualified Obelisk.Run"
435 , "import qualified Frontend"
326 , "import qualified Frontend"
436− , "import qualified Backend"
327+ , "import qualified Backend" ]
437− ]
328+ withSystemTempDirectory "ob-ghci" $ \fp -> do
438−
329+ let dotGhciPath = fp </> ".ghci"
439−-- | Builds a list of options to pass to ghci or set in .ghci file that configures
330+ liftIO $ writeFile dotGhciPath dotGhci
440−-- the preprocessor and source includes.
331+ f dotGhciPath
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
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
454− (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
455− canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
456− canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
457− pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
461− <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
462− <> concatMap (\p -> ["-optF", p]) pkgFiles
463− <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
465− relativeTo' = if useRelativePaths then relativeTo else const
334+ rootedSourceDirs pkg = NE.toList $
466−
335+ makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
467−baseGhciOptions :: [String]
469− [ "-ignore-dot-ghci"
470− , "-no-user-package-db"
471− , "-package-env", "-"
474-- | Run ghci repl
337-- | Run ghci repl
475runGhciRepl
338runGhciRepl
476− :: (MonadObelisk m, Foldable f)
339+ :: MonadObelisk m
477 => FilePath -- ^ Path to project root
340 => FilePath -- ^ Path to project root
478− -> f CabalPackageInfo -- ^ Packages to keep unbuilt
341+ -> [CabalPackageInfo]
479− -> [String] -- ^ GHCi arguments
342+ -> FilePath -- ^ Path to .ghci
481−runGhciRepl root (toList -> packages) ghciArgs =
344+runGhciRepl root packages dotGhci =
482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
345 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
483 -- ghc that is provided by the shell in the user's project.
346 -- ghc that is provided by the shell in the user's project.
484− nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
347+ nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
485− Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
487-- | Run ghcid
349-- | Run ghcid
489− :: (MonadObelisk m, Foldable f)
351+ :: MonadObelisk m
490 => FilePath -- ^ Path to project root
352 => FilePath -- ^ Path to project root
491 -> Bool -- ^ Should we chdir to root when running this process?
353 -> Bool -- ^ Should we chdir to root when running this process?
492− -> [String] -- ^ GHCi arguments
354+ -> FilePath -- ^ Path to .ghci
493− -> f CabalPackageInfo -- ^ Packages to keep unbuilt
355+ -> [CabalPackageInfo]
494 -> Maybe String -- ^ Optional command to run at every reload
356 -> Maybe String -- ^ Optional command to run at every reload
496−runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
358+runGhcid root chdirToRoot dotGhci packages mcmd =
497− nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
359+ nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
498− Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
500− opts = concat
361+ opts =
363+ , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
502− , ["--outputfile=ghcid-output.txt"]
364+ , "--outputfile=ghcid-output.txt"
503− , map (\x -> "--reload=" <> x) reloadFiles
365+ ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
504− , map (\x -> "--restart=" <> x) restartFiles
366+ <> map (\x -> "--restart='" <> x <> "'") restartFiles
505− , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
367+ <> testCmd
506− , ["--command=" <> unwords ("ghci" : ghciArgs)]
368+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
508 adjustRoot x = if chdirToRoot then makeRelative root x else x
370 adjustRoot x = if chdirToRoot then makeRelative root x else x
509 reloadFiles = map adjustRoot [root </> "config"]
371 reloadFiles = map adjustRoot [root </> "config"]
510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
372 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
374+makeBaseGhciOptions :: FilePath -> String
375+makeBaseGhciOptions dotGhci =
377+ [ "-no-user-package-db"
379+ , "-ghci-script " <> dotGhci
512−getFreePort :: MonadIO m => m Socket.PortNumber
382+getFreePort :: MonadIO m => m PortNumber
513−getFreePort = liftIO $ Socket.withSocketsDo $ do
383+getFreePort = liftIO $ withSocketsDo $ do
514− addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
384+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
515− bracket (open addr) Socket.close Socket.socketPort
385+ bracket (open addr) close socketPort
517 open addr = do
387 open addr = do
518− sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
388+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
519− Socket.bind sock (Socket.addrAddress addr)
389+ bind sock (addrAddress addr)
520 return sock
390 return sock
523−-- | Convert a 'FilePath' into a 'PathTree'.
524−pathToTree :: a -> FilePath -> PathTree a
525−pathToTree a p = go $ splitDirectories p
527− go [] = PathTree_Node (Just a) mempty
528− go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs
530−-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.
531−zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]
532−zipDefaultWith _da _db _f [] [] = []
533−zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []
534−zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs
535−zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs
537−-- | Makes the first absolute path relative to the second absolute path.
539−-- Both input paths MUST be absolute.
541−-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce
542−-- enough @..@ paths to make the resulting path truly relative in virtually every
543−-- case. The only exception is on Windows when the two paths are on different
544−-- drives. In this case the resulting path may be absolute.
545−relativeTo :: FilePath -> FilePath -> FilePath
548− $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)
550− $ dropWhile (\(a,b) -> a == b)
551− $ zipDefaultWith Nothing Nothing (,)
552− (map Just $ splitDirectories base)
553− (map Just $ splitDirectories dir)
554− where collapse = foldr (</>) ""