@@ -1,3 +1,6 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
14{-# LANGUAGE FlexibleContexts #-}
25{-# LANGUAGE LambdaCase #-}
36{-# LANGUAGE MultiParamTypeClasses #-}
@@ -11,21 +14,25 @@ module Obelisk.Command.Run where
1114import Control.Arrow ((&&&))
1215import Control.Exception (Exception, bracket)
1316import Control.Lens (ifor, (.~), (&))
14−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
1518import Control.Monad.Except (runExceptT, throwError)
1619import Control.Monad.IO.Class (liftIO)
1720import Control.Monad.Reader (MonadIO)
21+import Data.Bifoldable (bifoldr1)
22+import Data.Bifunctor (bimap)
1823import Data.Coerce (coerce)
1924import Data.Default (def)
2025import Data.Either (partitionEithers)
2126import Data.Foldable (fold, for_, toList)
22−import Data.Functor ((<&>))
27+import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
2329import Data.List.NonEmpty (NonEmpty)
2430import qualified Data.List.NonEmpty as NE
2531import Data.Map (Map)
2632import qualified Data.Map as Map
27−import Data.Maybe
28−import Data.Semigroup (Last (..))
33+import qualified Data.Map.Monoidal as MMap
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
2936import Data.Set (Set)
3037import qualified Data.Set as Set
3138import Data.String.Here.Interpolated (i)
@@ -39,42 +46,40 @@ import Distribution.Compiler (CompilerFlavor(..))
3946import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4047import Distribution.Parsec.ParseResult (runParseResult)
4148import qualified Distribution.System as Dist
42−import Distribution.Types.BuildInfo
43−import Distribution.Types.CondTree
44−import Distribution.Types.GenericPackageDescription
45−import Distribution.Types.Library
46−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)
4754import qualified Distribution.Parsec.Common as Dist
4855import qualified Hpack.Config as Hpack
4956import qualified Hpack.Render as Hpack
5057import qualified Hpack.Yaml as Hpack
51−import Language.Haskell.Extension
52−import Network.Socket hiding (Debug)
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
60+import System.Directory
5361import System.Environment (getExecutablePath)
62+import System.FilePath
5463import qualified System.Info
5564import System.IO.Temp (withSystemTempDirectory)
5665
5766import Obelisk.App (MonadObelisk)
5867import Obelisk.CliApp (
5968 Severity (..),
60− createProcess_,
6169 failWith,
6270 proc,
6371 putLog,
72+ readCreateProcessWithExitCode,
6473 readProcessAndLogStderr,
74+ runProcess_,
6575 setCwd,
6676 setDelegateCtlc,
67− waitForProcess,
6877 withSpinner,
6978 )
7079import Obelisk.Command.Nix
71−import Obelisk.Command.Path
72−import Obelisk.Command.Project (findProjectAssets, nixShellWithoutPkgs, obeliskDirName, withProjectRoot)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
7381import Obelisk.Command.Thunk (attrCacheFileName)
74−import Obelisk.Command.Utils (ghcidExePath)
75−
76−hpackFileName :: Path Relative
77−hpackFileName = rel Hpack.packageConfig
82+import Obelisk.Command.Utils (findExePath, ghcidExePath)
7883
7984data CabalPackageInfo = CabalPackageInfo
8085 { _cabalPackageInfo_packageFile :: FilePath
@@ -89,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
8994 -- ^ List of globally set languages of the library component
9095 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9196 -- ^ 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)
9299 }
93100
94−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
95102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
96103
97104textInterpret :: Interpret -> Text
@@ -99,6 +106,23 @@ textInterpret = \case
99106 Interpret_Interpret -> "Interpret"
100107 Interpret_NoInterpret -> "NoInterpret"
101108
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+
102126-- | Used to signal to obelisk that it's being invoked as a preprocessor
103127preprocessorIdentifier :: String
104128preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -124,10 +148,10 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
124148 putLog Debug $ "Assets impurely loaded from: " <> assets
125149 time <- liftIO getCurrentTime
126150 let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
127− createDirectoryIfMissing True $ takeDirectory $ mkPath root </> rel profileBaseName
128− putLog Debug [i|Storing profiled data under base name of ${root </> profileBaseName}|]
151+ liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152+ putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
129153 freePort <- getFreePort
130− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (toFilePath $ outPath </> rel "bin" </> rel "ob-run") $
154+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
131155 [ show freePort
132156 , T.unpack assets
133157 , profileBaseName
@@ -135,17 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
135159 , "-po" <> profileBaseName
136160 ] <> rtsFlags
137161 <> [ "-RTS" ]
138− void $ waitForProcess ph
139162
140−run :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
163+run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
141164run root interpretPaths = do
142165 pkgs <- getParsedLocalPkgs root interpretPaths
143− withGhciScript pkgs $ \dotGhciPath -> do
144− assets <- findProjectAssets root
145− putLog Debug $ "Assets impurely loaded from: " <> assets
146− ghciArgs <- getGhciSessionSettings pkgs root True
147− freePort <- getFreePort
148− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
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
149172 [ "Obelisk.Run.run"
150173 , show freePort
151174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -153,32 +176,32 @@ run root interpretPaths = do
153176 , "Frontend.frontend"
154177 ]
155178
156−runRepl :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
179+runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
157180runRepl root interpretPaths = do
158181 pkgs <- getParsedLocalPkgs root interpretPaths
159− ghciArgs <- getGhciSessionSettings pkgs (mkPath ".") True
160− withGhciScript pkgs $ \dotGhciPath ->
161− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
162185
163−runWatch :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
186+runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164187runWatch root interpretPaths = do
165188 pkgs <- getParsedLocalPkgs root interpretPaths
166189 ghciArgs <- getGhciSessionSettings pkgs root True
167− withGhciScript pkgs $ \dotGhciPath ->
168− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
169192
170−exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> Map (Path Canonical) Interpret -> m [String]
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
171194exportGhciConfig useRelativePaths root interpretPaths = do
172195 pkgs <- getParsedLocalPkgs root interpretPaths
173− getGhciSessionSettings pkgs (rel ".") useRelativePaths
196+ getGhciSessionSettings pkgs "." useRelativePaths
174197
175−nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> Map (Path Canonical) Interpret -> Maybe String -> m ()
198+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
176199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
177200 pkgs <- getParsedLocalPkgs root interpretPaths
178201 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
179202
180203-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
181−getParsedLocalPkgs :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (NonEmpty CabalPackageInfo)
204+getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
182205getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
183206
184207-- | Relative paths to local packages of an obelisk project.
@@ -186,36 +209,53 @@ getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs ro
186209-- These are a combination of the obelisk predefined local packages,
187210-- and any packages that the user has set with the @packages@ argument
188211-- to the Nix @project@ function.
189−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (Set (Path Canonical))
212+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
190213getLocalPkgs root interpretPaths = do
191− let pathTree :: PathTree Interpret = coerce $ foldMap (\(p, x) -> pathToTree (Last x) p) $ Map.toList interpretPaths
192− putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret pathTree
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"]
193216
194217 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
195218 -- obelisk project is our own.
196− canonicalRoot <- canonicalizePath root
197− obeliskPackageExclusions <- findFiles'
198− (\_ p -> if takeFileName p == rel obeliskDirName && p /= canonicalRoot
199− then liftIO (doesDirectoryExist p) <&> \case
200− True -> FindMatch_Match $ Set.singleton p
201− False -> FindMatch_SearchTree
202− else pure FindMatch_SearchTree
203− )
204− root
205−
206− let
207− findRoots = Map.keysSet $ Map.filter (== Interpret_Interpret) interpretPaths
208− exclusions = Map.keysSet $ Map.filter (== Interpret_NoInterpret) interpretPaths
209− <> Map.fromSet (const Interpret_NoInterpret) obeliskPackageExclusions -- Add these last because we want left side to override
210−
211− fmap fold $ for (toList findRoots) $ \interpretPathRoot -> do
212− findFiles'
213− (\_ p -> pure $ case () of
214− _ | p `Set.member` exclusions || attrCacheFileName `elem` splitDirectories p -> FindMatch_SkipTree
215− | takeExtension p == ".cabal" || takeFileName p == hpackFileName -> FindMatch_Match $ Set.singleton p
216− | otherwise -> FindMatch_SearchTree
217− )
218− interpretPathRoot
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]
229+ where
230+ runFind args = do
231+ (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
232+ putLog Debug $ T.strip $ T.pack err
233+ pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
234+
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
219259
220260data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
221261 deriving (Eq, Ord, Show)
@@ -226,24 +266,24 @@ newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (
226266
227267-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
228268guessCabalPackageFile
229− :: (MonadIO m, IsPath path)
230− => path -- ^ Directory or path to search for cabal package
269+ :: (MonadIO m)
270+ => FilePath -- ^ Directory or path to search for cabal package
231271 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
232−guessCabalPackageFile (toFilePath -> pkg) = do
272+guessCabalPackageFile pkg = do
233273 liftIO (doesDirectoryExist pkg) >>= \case
234274 False -> case cabalOrHpackFile pkg of
235275 (Just hpack@(Right _)) -> pure $ Right hpack
236276 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
237277 -- If the cabal file has a sibling hpack file, we use that instead
238278 -- since running hpack often generates a sibling cabal file
239− let possibleHpackSibling = takeDirectory $ mkPath cabalFilePath </> hpackFileName
279+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
240280 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
241− pure $ Right $ if hasHpackSibling then Right (HPackFilePath $ toFilePath possibleHpackSibling) else cabal
281+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
242282 Nothing -> pure $ Left GuessPackageFileError_NotFound
243283 True -> do
244284 candidates <- liftIO $
245285 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
246− =<< mapMaybe (cabalOrHpackFile . toFilePath . (pkg </>)) <$> listDirectory pkg
286+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
247287 pure $ case partitionEithers candidates of
248288 ([hpack], _) -> Right $ Left hpack
249289 ([], [cabal]) -> Right $ Right cabal
@@ -253,30 +293,31 @@ guessCabalPackageFile (toFilePath -> pkg) = do
253293cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
254294cabalOrHpackFile = \case
255295 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
256− | takeFileName x == hpackFileName -> Just (Right $ HPackFilePath x)
296+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
257297 | otherwise -> Nothing
258298
259299-- | Parses the cabal package in a given directory.
260300-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
261301parseCabalPackage
262− :: (MonadObelisk m, IsPath path)
263− => path
302+ :: MonadObelisk m
303+ => FilePath -- ^ Package directory
264304 -> m (Maybe CabalPackageInfo)
265305parseCabalPackage dir = parseCabalPackage' dir >>= \case
266306 Left err -> Nothing <$ putLog Error err
267− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
268308 for_ warnings $ putLog Warning . T.pack . show
269309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
270311
271312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
272313parseCabalPackage'
273− :: (MonadIO m, IsPath path)
274− => path -- ^ Package directory
275− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
276−parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do
314+ :: (MonadIO m)
315+ => FilePath -- ^ Package directory
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
317+parseCabalPackage' pkg = runExceptT $ do
277318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
278− Left GuessPackageFileError_NotFound -> throwError [i|No .cabal or package.yaml file found in ${pkg}|]
279− Left (GuessPackageFileError_Ambiguous _) -> throwError [i|Unable to determine which .cabal file to use in ${pkg}|]
319+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
320+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
280321 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
281322 Right (Right (HPackFilePath file)) -> do
282323 let
@@ -300,10 +341,10 @@ parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do
300341 case condLibrary <$> result of
301342 Right (Just condLib) -> do
302343 let (_, lib) = simplifyCondTree evalConfVar condLib
303− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
304345 { _cabalPackageInfo_packageName = T.pack packageName
305346 , _cabalPackageInfo_packageFile = packageFile
306− , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (mkPath packageFile)
347+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile
307348 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
308349 , _cabalPackageInfo_sourceDirs =
309350 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
@@ -312,18 +353,19 @@ parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do
312353 , _cabalPackageInfo_defaultLanguage =
313354 defaultLanguage $ libBuildInfo lib
314355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
315357 }
316− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
317359 Left (_, errors) ->
318− throwError $ [i|Failed to parse ${packageFile}:|] <> "\n" <> T.pack (unlines (map show errors))
360+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
319361
320−parsePackagesOrFail :: (MonadObelisk m, Foldable f, IsPath path) => f path -> m (NE.NonEmpty CabalPackageInfo)
362+parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
321363parsePackagesOrFail dirs' = do
322− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
323365 flip fmap (parseCabalPackage dir) $ \case
324366 Just packageInfo
325− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
326− _ -> Left dir
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
327369
328370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
329371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -342,12 +384,9 @@ parsePackagesOrFail dirs' = do
342384
343385 packageInfos <- case NE.nonEmpty $ toList unambiguous of
344386 Nothing -> failWith $ T.pack $
345− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (map toFilePath dirs))
387+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
346388 Just xs -> pure xs
347389
348− unless (null pkgDirErrs) $
349− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (map toFilePath pkgDirErrs)
350−
351390 pure packageInfos
352391 where
353392 dirs = toList dirs'
@@ -355,15 +394,31 @@ parsePackagesOrFail dirs' = do
355394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
356395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
357396
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+ ]
411+
358412-- | Create ghci configuration to load the given packages
359413withGhciScript
360414 :: (MonadObelisk m, Foldable f)
361− => f CabalPackageInfo -- ^ List of packages to load into ghci
415+ => [String] -- ^ Commands to prefix to file
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
362417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
363418 -> m ()
364−withGhciScript (toList -> packageInfos) f =
419+withGhciScript preCommands (toList -> packageInfos) f =
365420 withSystemTempDirectory "ob-ghci" $ \fp -> do
366− let dotGhciPath = toFilePath $ fp </> rel ".ghci"
421+ let dotGhciPath = fp </> ".ghci"
367422 liftIO $ writeFile dotGhciPath dotGhci
368423 f dotGhciPath
369424 where
@@ -373,7 +428,8 @@ withGhciScript (toList -> packageInfos) f =
373428 , [ "Backend" | "backend" `Set.member` packageNames ]
374429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
375430 ]
376− dotGhci = unlines
431+ dotGhci = unlines $
432+ preCommands <>
377433 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
378434 , "import qualified Obelisk.Run"
379435 , "import qualified Frontend"
@@ -383,17 +439,17 @@ withGhciScript (toList -> packageInfos) f =
383439-- | Builds a list of options to pass to ghci or set in .ghci file that configures
384440-- the preprocessor and source includes.
385441getGhciSessionSettings
386− :: (MonadObelisk m, Foldable f, IsPath path)
442+ :: (MonadObelisk m, Foldable f)
387443 => f CabalPackageInfo -- ^ List of packages to load into ghci
388− -> path -- ^ All paths will be relative to this path
444+ -> FilePath -- ^ All paths will be relative to this path
389445 -> Bool -- ^ Use relative paths
390446 -> m [String]
391447getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
392448 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
393449 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
394450 -- all paths to 'pathBase'.
395− selfExe <- canonicalizePath =<< liftIO getExecutablePath
396− canonicalPathBase <- canonicalizePath pathBase
451+ selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
452+ canonicalPathBase <- liftIO $ canonicalizePath pathBase
397453
398454 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
399455 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
@@ -402,12 +458,11 @@ getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
402458
403459 pure
404460 $ baseGhciOptions
405− <> ["-F", "-pgmF", toFilePath selfExe, "-optF", preprocessorIdentifier]
461+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
406462 <> concatMap (\p -> ["-optF", p]) pkgFiles
407463 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
408464 where
409− relativeTo' :: Path Canonical -> Path Canonical -> FilePath
410− relativeTo' a b = if useRelativePaths then toFilePath $ relativeTo a b else toFilePath a
465+ relativeTo' = if useRelativePaths then relativeTo else const
411466
412467baseGhciOptions :: [String]
413468baseGhciOptions =
@@ -427,7 +482,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
427482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
428483 -- ghc that is provided by the shell in the user's project.
429484 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
430− Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
431486
432487-- | Run ghcid
433488runGhcid
@@ -440,32 +495,60 @@ runGhcid
440495 -> m ()
441496runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
442497 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
443− Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
444499 where
445− opts =
446− [ "-W"
447− , "--outputfile=ghcid-output.txt"
448− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
449− <> map (\x -> "--restart='" <> x <> "'") restartFiles
450− <> testCmd
451− <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
452− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
453−
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+ ]
454508 adjustRoot x = if chdirToRoot then makeRelative root x else x
455− reloadFiles = map adjustRoot [toFilePath $ root </> rel "config"]
509+ reloadFiles = map adjustRoot [root </> "config"]
456510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
457511
458−mkGhciScriptArg :: IsPath path => path -> [String]
459−mkGhciScriptArg dotGhci = ["-ghci-script", toFilePath dotGhci]
460−
461−getFreePort :: MonadIO m => m PortNumber
462−getFreePort = liftIO $ withSocketsDo $ do
463− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
464− 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
465516 where
466517 open addr = do
467− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
468− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
469520 return sock
470521
471522
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 (</>) ""