@@ -1,6 +1,3 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveTraversable #-}
41{-# LANGUAGE FlexibleContexts #-}
52{-# LANGUAGE LambdaCase #-}
63{-# LANGUAGE MultiParamTypeClasses #-}
@@ -14,25 +11,21 @@ module Obelisk.Command.Run where
1411import Control.Arrow ((&&&))
1512import Control.Exception (Exception, bracket)
1613import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM)
14+import Control.Monad (filterM, unless, void)
1815import Control.Monad.Except (runExceptT, throwError)
1916import Control.Monad.IO.Class (liftIO)
2017import Control.Monad.Reader (MonadIO)
21−import Data.Bifoldable (bifoldr1)
22−import Data.Bifunctor (bimap)
2318import Data.Coerce (coerce)
2419import Data.Default (def)
2520import Data.Either (partitionEithers)
2621import Data.Foldable (fold, for_, toList)
27−import Data.Functor.Identity (runIdentity)
28−import Data.List (intercalate)
22+import Data.Functor ((<&>))
2923import Data.List.NonEmpty (NonEmpty)
3024import qualified Data.List.NonEmpty as NE
3125import Data.Map (Map)
3226import qualified Data.Map as Map
33−import qualified Data.Map.Monoidal as MMap
34−import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35−import Data.Ord (comparing)
27+import Data.Maybe
28+import Data.Semigroup (Last (..))
3629import Data.Set (Set)
3730import qualified Data.Set as Set
3831import Data.String.Here.Interpolated (i)
@@ -46,40 +39,42 @@ import Distribution.Compiler (CompilerFlavor(..))
4639import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4740import Distribution.Parsec.ParseResult (runParseResult)
4841import qualified Distribution.System as Dist
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)
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
5447import qualified Distribution.Parsec.Common as Dist
5548import qualified Hpack.Config as Hpack
5649import qualified Hpack.Render as Hpack
5750import qualified Hpack.Yaml as Hpack
58−import Language.Haskell.Extension (Extension, Language)
59−import qualified Network.Socket as Socket
60−import System.Directory
51+import Language.Haskell.Extension
52+import Network.Socket hiding (Debug)
6153import System.Environment (getExecutablePath)
62−import System.FilePath
6354import qualified System.Info
6455import System.IO.Temp (withSystemTempDirectory)
6556
6657import Obelisk.App (MonadObelisk)
6758import Obelisk.CliApp (
6859 Severity (..),
60+ createProcess_,
6961 failWith,
7062 proc,
7163 putLog,
72− readCreateProcessWithExitCode,
7364 readProcessAndLogStderr,
74− runProcess_,
7565 setCwd,
7666 setDelegateCtlc,
67+ waitForProcess,
7768 withSpinner,
7869 )
7970import Obelisk.Command.Nix
80−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
71+import Obelisk.Command.Path
72+import Obelisk.Command.Project (findProjectAssets, nixShellWithoutPkgs, obeliskDirName, withProjectRoot)
8173import Obelisk.Command.Thunk (attrCacheFileName)
82−import Obelisk.Command.Utils (findExePath, ghcidExePath)
74+import Obelisk.Command.Utils (ghcidExePath)
75+
76+hpackFileName :: Path Relative
77+hpackFileName = rel Hpack.packageConfig
8378
8479data CabalPackageInfo = CabalPackageInfo
8580 { _cabalPackageInfo_packageFile :: FilePath
@@ -94,11 +89,9 @@ data CabalPackageInfo = CabalPackageInfo
9489 -- ^ List of globally set languages of the library component
9590 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9691 -- ^ 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)
9992 }
10093
101−-- | 'Bool' with a better name for its purpose.
94+-- | 'Bool' with a better name for it's purpose.
10295data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
10396
10497textInterpret :: Interpret -> Text
@@ -106,23 +99,6 @@ textInterpret = \case
10699 Interpret_Interpret -> "Interpret"
107100 Interpret_NoInterpret -> "NoInterpret"
108101
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−
126102-- | Used to signal to obelisk that it's being invoked as a preprocessor
127103preprocessorIdentifier :: String
128104preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -148,10 +124,10 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
148124 putLog Debug $ "Assets impurely loaded from: " <> assets
149125 time <- liftIO getCurrentTime
150126 let profileBaseName = formatTime defaultTimeLocale profileBasePattern time
151− liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152− putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
127+ createDirectoryIfMissing True $ takeDirectory $ mkPath root </> rel profileBaseName
128+ putLog Debug [i|Storing profiled data under base name of ${root </> profileBaseName}|]
153129 freePort <- getFreePort
154− runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
130+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (toFilePath $ outPath </> rel "bin" </> rel "ob-run") $
155131 [ show freePort
156132 , T.unpack assets
157133 , profileBaseName
@@ -159,16 +135,17 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159135 , "-po" <> profileBaseName
160136 ] <> rtsFlags
161137 <> [ "-RTS" ]
138+ void $ waitForProcess ph
162139
163−run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
140+run :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
164141run root interpretPaths = do
165142 pkgs <- getParsedLocalPkgs root interpretPaths
166− assets <- findProjectAssets root
167− putLog Debug $ "Assets impurely loaded from: " <> assets
168− ghciArgs <- getGhciSessionSettings pkgs root True
169− freePort <- getFreePort
170− withGhciScriptArgs pkgs $ \dotGhciArgs -> do
171− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
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
172149 [ "Obelisk.Run.run"
173150 , show freePort
174151 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -176,32 +153,32 @@ run root interpretPaths = do
176153 , "Frontend.frontend"
177154 ]
178155
179−runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
156+runRepl :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
180157runRepl root interpretPaths = do
181158 pkgs <- getParsedLocalPkgs root interpretPaths
182− ghciArgs <- getGhciSessionSettings pkgs "." True
183− withGhciScriptArgs pkgs $ \dotGhciArgs ->
184− runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
159+ ghciArgs <- getGhciSessionSettings pkgs (mkPath ".") True
160+ withGhciScript pkgs $ \dotGhciPath ->
161+ runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
185162
186−runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163+runWatch :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m ()
187164runWatch root interpretPaths = do
188165 pkgs <- getParsedLocalPkgs root interpretPaths
189166 ghciArgs <- getGhciSessionSettings pkgs root True
190− withGhciScriptArgs pkgs $ \dotGhciArgs ->
191− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
167+ withGhciScript pkgs $ \dotGhciPath ->
168+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
192169
193−exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
170+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> Map (Path Canonical) Interpret -> m [String]
194171exportGhciConfig useRelativePaths root interpretPaths = do
195172 pkgs <- getParsedLocalPkgs root interpretPaths
196− getGhciSessionSettings pkgs "." useRelativePaths
173+ getGhciSessionSettings pkgs (rel ".") useRelativePaths
197174
198−nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
175+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> Map (Path Canonical) Interpret -> Maybe String -> m ()
199176nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200177 pkgs <- getParsedLocalPkgs root interpretPaths
201178 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
202179
203180-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
204−getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
181+getParsedLocalPkgs :: MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (NonEmpty CabalPackageInfo)
205182getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
206183
207184-- | Relative paths to local packages of an obelisk project.
@@ -209,53 +186,36 @@ getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs ro
209186-- These are a combination of the obelisk predefined local packages,
210187-- and any packages that the user has set with the @packages@ argument
211188-- to the Nix @project@ function.
212−getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
189+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> Map (Path Canonical) Interpret -> m (Set (Path Canonical))
213190getLocalPkgs root interpretPaths = do
214− putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
215− obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
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
216193
217194 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
218195 -- obelisk project is our own.
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
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
259219
260220data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
261221 deriving (Eq, Ord, Show)
@@ -266,24 +226,24 @@ newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (
266226
267227-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
268228guessCabalPackageFile
269− :: (MonadIO m)
270− => FilePath -- ^ Directory or path to search for cabal package
229+ :: (MonadIO m, IsPath path)
230+ => path -- ^ Directory or path to search for cabal package
271231 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
272−guessCabalPackageFile pkg = do
232+guessCabalPackageFile (toFilePath -> pkg) = do
273233 liftIO (doesDirectoryExist pkg) >>= \case
274234 False -> case cabalOrHpackFile pkg of
275235 (Just hpack@(Right _)) -> pure $ Right hpack
276236 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
277237 -- If the cabal file has a sibling hpack file, we use that instead
278238 -- since running hpack often generates a sibling cabal file
279− let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
239+ let possibleHpackSibling = takeDirectory $ mkPath cabalFilePath </> hpackFileName
280240 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
281− pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
241+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath $ toFilePath possibleHpackSibling) else cabal
282242 Nothing -> pure $ Left GuessPackageFileError_NotFound
283243 True -> do
284244 candidates <- liftIO $
285245 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
286− =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
246+ =<< mapMaybe (cabalOrHpackFile . toFilePath . (pkg </>)) <$> listDirectory pkg
287247 pure $ case partitionEithers candidates of
288248 ([hpack], _) -> Right $ Left hpack
289249 ([], [cabal]) -> Right $ Right cabal
@@ -293,31 +253,30 @@ guessCabalPackageFile pkg = do
293253cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
294254cabalOrHpackFile = \case
295255 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
296− | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
256+ | takeFileName x == hpackFileName -> Just (Right $ HPackFilePath x)
297257 | otherwise -> Nothing
298258
299259-- | Parses the cabal package in a given directory.
300260-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
301261parseCabalPackage
302− :: MonadObelisk m
303− => FilePath -- ^ Package directory
262+ :: (MonadObelisk m, IsPath path)
263+ => path
304264 -> m (Maybe CabalPackageInfo)
305265parseCabalPackage dir = parseCabalPackage' dir >>= \case
306266 Left err -> Nothing <$ putLog Error err
307− Right (Just (warnings, pkgInfo)) -> do
267+ Right (warnings, pkgInfo) -> do
308268 for_ warnings $ putLog Warning . T.pack . show
309269 pure $ Just pkgInfo
310− Right Nothing -> pure Nothing
311270
312271-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313272parseCabalPackage'
314− :: (MonadIO m)
315− => FilePath -- ^ Package directory
316− -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
317−parseCabalPackage' pkg = runExceptT $ do
273+ :: (MonadIO m, IsPath path)
274+ => path -- ^ Package directory
275+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
276+parseCabalPackage' (toFilePath -> pkg) = runExceptT $ do
318277 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
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
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}|]
321280 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
322281 Right (Right (HPackFilePath file)) -> do
323282 let
@@ -341,10 +300,10 @@ parseCabalPackage' pkg = runExceptT $ do
341300 case condLibrary <$> result of
342301 Right (Just condLib) -> do
343302 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ Just $ (warnings,) $ CabalPackageInfo
303+ pure $ (warnings,) $ CabalPackageInfo
345304 { _cabalPackageInfo_packageName = T.pack packageName
346305 , _cabalPackageInfo_packageFile = packageFile
347− , _cabalPackageInfo_packageRoot = takeDirectory packageFile
306+ , _cabalPackageInfo_packageRoot = unPath $ takeDirectory (mkPath packageFile)
348307 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
349308 , _cabalPackageInfo_sourceDirs =
350309 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
@@ -353,19 +312,18 @@ parseCabalPackage' pkg = runExceptT $ do
353312 , _cabalPackageInfo_defaultLanguage =
354313 defaultLanguage $ libBuildInfo lib
355314 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356− , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
357315 }
358− Right Nothing -> pure Nothing
316+ Right Nothing -> throwError "Haskell package has no library component"
359317 Left (_, errors) ->
360− throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
318+ throwError $ [i|Failed to parse ${packageFile}:|] <> "\n" <> T.pack (unlines (map show errors))
361319
362−parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
320+parsePackagesOrFail :: (MonadObelisk m, Foldable f, IsPath path) => f path -> m (NE.NonEmpty CabalPackageInfo)
363321parsePackagesOrFail dirs' = do
364− packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
322+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
365323 flip fmap (parseCabalPackage dir) $ \case
366324 Just packageInfo
367− | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368− _ -> Nothing
325+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
326+ _ -> Left dir
369327
370328 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371329 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -384,9 +342,12 @@ parsePackagesOrFail dirs' = do
384342
385343 packageInfos <- case NE.nonEmpty $ toList unambiguous of
386344 Nothing -> failWith $ T.pack $
387− "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
345+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " (map toFilePath dirs))
388346 Just xs -> pure xs
389347
348+ unless (null pkgDirErrs) $
349+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " (map toFilePath pkgDirErrs)
350+
390351 pure packageInfos
391352 where
392353 dirs = toList dirs'
@@ -394,31 +355,15 @@ parsePackagesOrFail dirs' = do
394355packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395356packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
396357
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−
412358-- | Create ghci configuration to load the given packages
413359withGhciScript
414360 :: (MonadObelisk m, Foldable f)
415− => [String] -- ^ Commands to prefix to file
416− -> f CabalPackageInfo -- ^ List of packages to load into ghci
361+ => f CabalPackageInfo -- ^ List of packages to load into ghci
417362 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
418363 -> m ()
419−withGhciScript preCommands (toList -> packageInfos) f =
364+withGhciScript (toList -> packageInfos) f =
420365 withSystemTempDirectory "ob-ghci" $ \fp -> do
421− let dotGhciPath = fp </> ".ghci"
366+ let dotGhciPath = toFilePath $ fp </> rel ".ghci"
422367 liftIO $ writeFile dotGhciPath dotGhci
423368 f dotGhciPath
424369 where
@@ -428,8 +373,7 @@ withGhciScript preCommands (toList -> packageInfos) f =
428373 , [ "Backend" | "backend" `Set.member` packageNames ]
429374 , [ "Frontend" | "frontend" `Set.member` packageNames ]
430375 ]
431− dotGhci = unlines $
432− preCommands <>
376+ dotGhci = unlines
433377 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434378 , "import qualified Obelisk.Run"
435379 , "import qualified Frontend"
@@ -439,17 +383,17 @@ withGhciScript preCommands (toList -> packageInfos) f =
439383-- | Builds a list of options to pass to ghci or set in .ghci file that configures
440384-- the preprocessor and source includes.
441385getGhciSessionSettings
442− :: (MonadObelisk m, Foldable f)
386+ :: (MonadObelisk m, Foldable f, IsPath path)
443387 => f CabalPackageInfo -- ^ List of packages to load into ghci
444− -> FilePath -- ^ All paths will be relative to this path
388+ -> path -- ^ All paths will be relative to this path
445389 -> Bool -- ^ Use relative paths
446390 -> m [String]
447391getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
448392 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
449393 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
450394 -- all paths to 'pathBase'.
451− selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
452− canonicalPathBase <- liftIO $ canonicalizePath pathBase
395+ selfExe <- canonicalizePath =<< liftIO getExecutablePath
396+ canonicalPathBase <- canonicalizePath pathBase
453397
454398 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
455399 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
@@ -458,11 +402,12 @@ getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
458402
459403 pure
460404 $ baseGhciOptions
461− <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
405+ <> ["-F", "-pgmF", toFilePath selfExe, "-optF", preprocessorIdentifier]
462406 <> concatMap (\p -> ["-optF", p]) pkgFiles
463407 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
464408 where
465− relativeTo' = if useRelativePaths then relativeTo else const
409+ relativeTo' :: Path Canonical -> Path Canonical -> FilePath
410+ relativeTo' a b = if useRelativePaths then toFilePath $ relativeTo a b else toFilePath a
466411
467412baseGhciOptions :: [String]
468413baseGhciOptions =
@@ -482,7 +427,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
482427 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
483428 -- ghc that is provided by the shell in the user's project.
484429 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485− Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
430+ Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
486431
487432-- | Run ghcid
488433runGhcid
@@ -495,60 +440,32 @@ runGhcid
495440 -> m ()
496441runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497442 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498− Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
443+ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
499444 where
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− ]
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+
508454 adjustRoot x = if chdirToRoot then makeRelative root x else x
509− reloadFiles = map adjustRoot [root </> "config"]
455+ reloadFiles = map adjustRoot [toFilePath $ root </> rel "config"]
510456 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
511457
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
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
516465 where
517466 open addr = do
518− sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519− Socket.bind sock (Socket.addrAddress addr)
467+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
468+ bind sock (addrAddress addr)
520469 return sock
521470
522471
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 (</>) ""