@@ -1,27 +1,41 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
1{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE QuasiQuotes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE ViewPatterns #-}
7module Obelisk.Command.Run where
12module Obelisk.Command.Run where
9import Control.Arrow ((&&&))
14import Control.Arrow ((&&&))
10import Control.Exception (Exception, bracket)
15import Control.Exception (Exception, bracket)
11import Control.Lens (ifor, (.~), (&))
16import Control.Lens (ifor, (.~), (&))
12−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
13import Control.Monad.Except (runExceptT, throwError)
18import Control.Monad.Except (runExceptT, throwError)
14import Control.Monad.IO.Class (liftIO)
19import Control.Monad.IO.Class (liftIO)
15import Control.Monad.Reader (MonadIO)
20import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
16import Data.Coerce (coerce)
23import Data.Coerce (coerce)
17import Data.Default (def)
24import Data.Default (def)
18−import Data.Either
25+import Data.Either (partitionEithers)
19−import Data.Foldable (for_, toList)
26+import Data.Foldable (fold, for_, toList)
27+import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
29+import Data.List.NonEmpty (NonEmpty)
20import qualified Data.List.NonEmpty as NE
30import qualified Data.List.NonEmpty as NE
21import Data.Map (Map)
31import Data.Map (Map)
22import qualified Data.Map as Map
32import 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)
24import qualified Data.Set as Set
37import qualified Data.Set as Set
38+import Data.String.Here.Interpolated (i)
25import Data.Text (Text)
39import Data.Text (Text)
26import qualified Data.Text as T
40import qualified Data.Text as T
27import Data.Time.Clock (getCurrentTime)
41import Data.Time.Clock (getCurrentTime)
@@ -32,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
32import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
33import Distribution.Parsec.ParseResult (runParseResult)
47import Distribution.Parsec.ParseResult (runParseResult)
34import qualified Distribution.System as Dist
48import qualified Distribution.System as Dist
35−import Distribution.Types.BuildInfo
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
36−import Distribution.Types.CondTree
50+import Distribution.Types.CondTree (simplifyCondTree)
37−import Distribution.Types.GenericPackageDescription
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
38−import Distribution.Types.Library
52+import Distribution.Types.Library (libBuildInfo)
39−import Distribution.Utils.Generic
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
40import qualified Distribution.Parsec.Common as Dist
54import qualified Distribution.Parsec.Common as Dist
41import qualified Hpack.Config as Hpack
55import qualified Hpack.Config as Hpack
42import qualified Hpack.Render as Hpack
56import qualified Hpack.Render as Hpack
43import qualified Hpack.Yaml as Hpack
57import qualified Hpack.Yaml as Hpack
44−import Language.Haskell.Extension
58+import Language.Haskell.Extension (Extension, Language)
45−import Network.Socket hiding (Debug)
59+import qualified Network.Socket as Socket
46import System.Directory
60import System.Directory
47import System.Environment (getExecutablePath)
61import System.Environment (getExecutablePath)
48import System.FilePath
62import System.FilePath
@@ -52,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
52import Obelisk.App (MonadObelisk)
66import Obelisk.App (MonadObelisk)
53import Obelisk.CliApp (
67import Obelisk.CliApp (
54 Severity (..),
68 Severity (..),
59 readCreateProcessWithExitCode,
72 readCreateProcessWithExitCode,
60 readProcessAndLogStderr,
73 readProcessAndLogStderr,
62 setDelegateCtlc,
76 setDelegateCtlc,
64 withSpinner,
77 withSpinner,
66import Obelisk.Command.Nix
79import Obelisk.Command.Nix
67−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
68import Obelisk.Command.Thunk (attrCacheFileName)
81import Obelisk.Command.Thunk (attrCacheFileName)
69import Obelisk.Command.Utils (findExePath, ghcidExePath)
82import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -81,8 +94,35 @@ data CabalPackageInfo = CabalPackageInfo
81 -- ^ List of globally set languages of the library component
94 -- ^ List of globally set languages of the library component
82 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
95 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
83 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
96 -- ^ 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)
86-- | Used to signal to obelisk that it's being invoked as a preprocessor
126-- | Used to signal to obelisk that it's being invoked as a preprocessor
87preprocessorIdentifier :: String
127preprocessorIdentifier :: String
88preprocessorIdentifier = "__preprocessor-apply-packages"
128preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -111,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
111 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
112 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
113 freePort <- getFreePort
153 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") $
115 [ show freePort
155 [ show freePort
116 , T.unpack assets
156 , T.unpack assets
117 , profileBaseName
157 , profileBaseName
@@ -119,18 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
119 , "-po" <> profileBaseName
159 , "-po" <> profileBaseName
120 ] <> rtsFlags
160 ] <> rtsFlags
121 <> [ "-RTS" ]
161 <> [ "-RTS" ]
122− void $ waitForProcess ph
125− :: MonadObelisk m
163+run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
126− => m ()
164+run root interpretPaths = do
127−run = withProjectRoot "." $ \root -> do
165+ pkgs <- getParsedLocalPkgs root interpretPaths
128− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
129− withGhciScript pkgs root $ \dotGhciPath -> do
130− freePort <- getFreePort
131− assets <- findProjectAssets root
166+ assets <- findProjectAssets root
132− putLog Debug $ "Assets impurely loaded from: " <> assets
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ ghciArgs <- getGhciSessionSettings pkgs root True
169+ freePort <- getFreePort
170+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
133− runGhcid root True dotGhciPath pkgs $ Just $ unwords
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
134 [ "Obelisk.Run.run"
172 [ "Obelisk.Run.run"
135 , show freePort
173 , show freePort
136 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -138,39 +176,87 @@ run = withProjectRoot "." $ \root -> do
138 , "Frontend.frontend"
176 , "Frontend.frontend"
141−runRepl :: MonadObelisk m => m ()
179+runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
142−runRepl = withProjectRoot "." $ \root -> do
180+runRepl root interpretPaths = do
143− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
181+ pkgs <- getParsedLocalPkgs root interpretPaths
144− withGhciScript pkgs "." $ \dotGhciPath ->
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
145− runGhciRepl root pkgs dotGhciPath
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
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
147−runWatch :: MonadObelisk m => m ()
203+-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
148−runWatch = withProjectRoot "." $ \root -> do
204+getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
149− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
205+getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
150− withGhciScript pkgs root $ \dotGhciPath ->
151− runGhcid root True dotGhciPath pkgs Nothing
153-- | Relative paths to local packages of an obelisk project.
207-- | Relative paths to local packages of an obelisk project.
155-- These are a combination of the obelisk predefined local packages,
209-- These are a combination of the obelisk predefined local packages,
156-- and any packages that the user has set with the @packages@ argument
210-- and any packages that the user has set with the @packages@ argument
157-- to the Nix @project@ function.
211-- to the Nix @project@ function.
158−getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
212+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
159−getLocalPkgs root = do
213+getLocalPkgs root interpretPaths = do
214+ putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
160− obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
215+ obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
162 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
163 -- obelisk project is our own.
218 -- obelisk project is our own.
219+ obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
164− let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
220+ filter (/= root) $ map takeDirectory obeliskPackagePaths
165− fmap (map (makeRelative ".")) $ runFind $
221+ putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
222+ let rootsAndExclusions = calcIntepretFinds "" interpretPaths
224+ fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
225+ let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
226+ in fmap (Set.fromList . map normalise) $ runFind $
166− ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
227+ ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
167− <> concat [["-not", "-path", p </> "*"] | p <- ("*" </> attrCacheFileName) : exclusions]
228+ <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
169 runFind args = do
230 runFind args = do
170 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
231 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
171 putLog Debug $ T.strip $ T.pack err
232 putLog Debug $ T.strip $ T.pack err
172 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
233 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
235+-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
236+-- This is used when constructing a set of @find@ commands to run to produce a set of packages
237+-- that matches the user's @--interpret@/@--no-interpret@ settings.
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
174data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
260data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
175 deriving (Eq, Ord, Show)
261 deriving (Eq, Ord, Show)
176instance Exception GuessPackageFileError
262instance Exception GuessPackageFileError
@@ -218,15 +304,16 @@ parseCabalPackage
218 -> m (Maybe CabalPackageInfo)
304 -> m (Maybe CabalPackageInfo)
219parseCabalPackage dir = parseCabalPackage' dir >>= \case
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
220 Left err -> Nothing <$ putLog Error err
306 Left err -> Nothing <$ putLog Error err
221− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
222 for_ warnings $ putLog Warning . T.pack . show
308 for_ warnings $ putLog Warning . T.pack . show
223 pure $ Just pkgInfo
309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
225-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
226parseCabalPackage'
313parseCabalPackage'
227 :: (MonadIO m)
314 :: (MonadIO m)
228 => FilePath -- ^ Package directory
315 => FilePath -- ^ Package directory
229− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
230parseCabalPackage' pkg = runExceptT $ do
317parseCabalPackage' pkg = runExceptT $ do
231 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
232 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -254,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
254 case condLibrary <$> result of
341 case condLibrary <$> result of
255 Right (Just condLib) -> do
342 Right (Just condLib) -> do
256 let (_, lib) = simplifyCondTree evalConfVar condLib
343 let (_, lib) = simplifyCondTree evalConfVar condLib
257− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
258 { _cabalPackageInfo_packageName = T.pack packageName
345 { _cabalPackageInfo_packageName = T.pack packageName
259 , _cabalPackageInfo_packageFile = packageFile
346 , _cabalPackageInfo_packageFile = packageFile
260 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -266,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
266 , _cabalPackageInfo_defaultLanguage =
353 , _cabalPackageInfo_defaultLanguage =
267 defaultLanguage $ libBuildInfo lib
354 defaultLanguage $ libBuildInfo lib
268 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
270− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
271 Left (_, errors) ->
359 Left (_, errors) ->
272 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
274−parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
362+parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
275−parsePackagesOrFail dirs = do
363+parsePackagesOrFail dirs' = do
276− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
277 flip fmap (parseCabalPackage dir) $ \case
365 flip fmap (parseCabalPackage dir) $ \case
278 Just packageInfo
366 Just packageInfo
279− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
280− _ -> Left dir
368+ _ -> Nothing
282 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
283 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -285,108 +373,182 @@ parsePackagesOrFail dirs = do
285 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
373 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
286 p NE.:| [] -> pure p -- No ambiguity here
374 p NE.:| [] -> pure p -- No ambiguity here
287 p NE.:| _ -> do
375 p NE.:| _ -> do
376+ let chosenText = " [Chosen] "
378+ | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText
379+ | otherwise = T.map (const ' ') chosenText
288− putLog Warning $ T.pack $
380+ putLog Warning $ T.unlines $
289− "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "
381+ "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "
290− <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)
382+ : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)
291− <> "; Picking " <> _cabalPackageInfo_packageFile p
294 packageInfos <- case NE.nonEmpty $ toList unambiguous of
385 packageInfos <- case NE.nonEmpty $ toList unambiguous of
386+ Nothing -> failWith $ T.pack $
295− Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
387+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
296 Just xs -> pure xs
388 Just xs -> pure xs
298− unless (null pkgDirErrs) $
299− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
301 pure packageInfos
390 pure packageInfos
303−packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
394+packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
304−packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
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
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
306-- | Create ghci configuration to load the given packages
412-- | Create ghci configuration to load the given packages
307withGhciScript
413withGhciScript
308− :: MonadObelisk m
414+ :: (MonadObelisk m, Foldable f)
415+ => [String] -- ^ Commands to prefix to file
309− => [CabalPackageInfo] -- ^ List of packages to load into ghci
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
310− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
311 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
313−withGhciScript packageInfos pathBase f = do
419+withGhciScript preCommands (toList -> packageInfos) f =
314− selfExe <- liftIO getExecutablePath
420+ withSystemTempDirectory "ob-ghci" $ \fp -> do
315− let
421+ let dotGhciPath = fp </> ".ghci"
422+ liftIO $ writeFile dotGhciPath dotGhci
316 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
425 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
317 modulesToLoad = mconcat
426 modulesToLoad = mconcat
318 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
427 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
319 , [ "Backend" | "backend" `Set.member` packageNames ]
428 , [ "Backend" | "backend" `Set.member` packageNames ]
320 , [ "Frontend" | "frontend" `Set.member` packageNames ]
429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
322− dotGhci = unlines
431+ dotGhci = unlines $
323− -- TODO: Shell escape
432+ preCommands <>
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
433+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
327 , "import qualified Obelisk.Run"
434 , "import qualified Obelisk.Run"
328 , "import qualified Frontend"
435 , "import qualified Frontend"
329− , "import qualified Backend" ]
436+ , "import qualified Backend"
330− withSystemTempDirectory "ob-ghci" $ \fp -> do
437+ ]
331− let dotGhciPath = fp </> ".ghci"
438+
332− liftIO $ writeFile dotGhciPath dotGhci
439+-- | Builds a list of options to pass to ghci or set in .ghci file that configures
333− f dotGhciPath
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
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) ]
336− rootedSourceDirs pkg = NE.toList $
465+ relativeTo' = if useRelativePaths then relativeTo else const
337− makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
466+
467+baseGhciOptions :: [String]
469+ [ "-ignore-dot-ghci"
470+ , "-no-user-package-db"
471+ , "-package-env", "-"
339-- | Run ghci repl
474-- | Run ghci repl
340runGhciRepl
475runGhciRepl
341− :: MonadObelisk m
476+ :: (MonadObelisk m, Foldable f)
342 => FilePath -- ^ Path to project root
477 => FilePath -- ^ Path to project root
343− -> [CabalPackageInfo]
478+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
344− -> FilePath -- ^ Path to .ghci
479+ -> [String] -- ^ GHCi arguments
346−runGhciRepl root packages dotGhci =
481+runGhciRepl root (toList -> packages) ghciArgs =
347 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
348 -- ghc that is provided by the shell in the user's project.
483 -- 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
351-- | Run ghcid
487-- | Run ghcid
353− :: MonadObelisk m
489+ :: (MonadObelisk m, Foldable f)
354 => FilePath -- ^ Path to project root
490 => FilePath -- ^ Path to project root
355 -> Bool -- ^ Should we chdir to root when running this process?
491 -> Bool -- ^ Should we chdir to root when running this process?
356− -> FilePath -- ^ Path to .ghci
492+ -> [String] -- ^ GHCi arguments
357− -> [CabalPackageInfo]
493+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt
358 -> Maybe String -- ^ Optional command to run at every reload
494 -> Maybe String -- ^ Optional command to run at every reload
360−runGhcid root chdirToRoot dotGhci packages mcmd =
496+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
361− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
497+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
363− opts =
500+ opts = concat
365− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
366− , "--outputfile=ghcid-output.txt"
502+ , ["--outputfile=ghcid-output.txt"]
367− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
503+ , map (\x -> "--reload=" <> x) reloadFiles
368− <> map (\x -> "--restart='" <> x <> "'") restartFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
369− <> testCmd
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
370− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
372 adjustRoot x = if chdirToRoot then makeRelative root x else x
508 adjustRoot x = if chdirToRoot then makeRelative root x else x
373 reloadFiles = map adjustRoot [root </> "config"]
509 reloadFiles = map adjustRoot [root </> "config"]
374 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
376−makeBaseGhciOptions :: FilePath -> String
377−makeBaseGhciOptions dotGhci =
379− [ "-no-user-package-db"
381− , "-ghci-script " <> dotGhci
384−getFreePort :: MonadIO m => m PortNumber
512+getFreePort :: MonadIO m => m Socket.PortNumber
385−getFreePort = liftIO $ withSocketsDo $ do
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
386− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
387− bracket (open addr) close socketPort
515+ bracket (open addr) Socket.close Socket.socketPort
389 open addr = do
517 open addr = do
390− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
391− bind sock (addrAddress addr)
519+ Socket.bind sock (Socket.addrAddress addr)
392 return sock
520 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 (</>) ""