@@ -1,9 +1,14 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
14{-# LANGUAGE FlexibleContexts #-}
25{-# LANGUAGE LambdaCase #-}
36{-# LANGUAGE MultiParamTypeClasses #-}
47{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE QuasiQuotes #-}
59{-# LANGUAGE ScopedTypeVariables #-}
610{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE ViewPatterns #-}
712module Obelisk.Command.Run where
813
914import Control.Arrow ((&&&))
@@ -15,13 +20,18 @@ import Control.Monad.IO.Class (liftIO)
1520import Control.Monad.Reader (MonadIO)
1621import Data.Coerce (coerce)
1722import Data.Default (def)
18−import Data.Either
19−import Data.Foldable (for_, toList)
23+import Data.Either (partitionEithers)
24+import Data.Foldable (fold, for_, toList)
25+import Data.Functor.Identity (runIdentity)
26+import Data.List.NonEmpty (NonEmpty)
2027import qualified Data.List.NonEmpty as NE
2128import Data.Map (Map)
2229import qualified Data.Map as Map
30+import qualified Data.Map.Monoidal as MMap
2331import Data.Maybe
32+import Data.Set (Set)
2433import qualified Data.Set as Set
34+import Data.String.Here.Interpolated (i)
2535import Data.Text (Text)
2636import qualified Data.Text as T
2737import Data.Time.Clock (getCurrentTime)
@@ -83,6 +93,34 @@ data CabalPackageInfo = CabalPackageInfo
8393 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
8494 }
8595
96+-- | 'Bool' with a better name for it's purpose.
97+data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
98+
99+textInterpret :: Interpret -> Text
100+textInterpret = \case
101+ Interpret_Interpret -> "Interpret"
102+ Interpret_NoInterpret -> "NoInterpret"
103+
104+-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way.
105+data PathTree a = PathTree_Node
106+ (Maybe a) -- An optional leaf at this point in the tree
107+ (Map FilePath (PathTree a)) -- Branches to deeper leaves
108+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
109+
110+emptyPathTree :: PathTree a
111+emptyPathTree = PathTree_Node Nothing mempty
112+
113+-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
114+drawPathTree :: (a -> Text) -> PathTree a -> Text
115+drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
116+ where
117+ annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack
118+ goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest)
119+ goForest [] = []
120+ goForest [tree] = shift "└─ " " " (goTree tree)
121+ goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest
122+ shift first other = zipWith (<>) (first : repeat other)
123+
86124-- | Used to signal to obelisk that it's being invoked as a preprocessor
87125preprocessorIdentifier :: String
88126preprocessorIdentifier = "__preprocessor-apply-packages"
@@ -121,11 +159,9 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
121159 <> [ "-RTS" ]
122160 void $ waitForProcess ph
123161
124−run
125− :: MonadObelisk m
126− => m ()
127−run = withProjectRoot "." $ \root -> do
128− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
162+run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
163+run root interpretPaths = do
164+ pkgs <- getParsedLocalPkgs root interpretPaths
129165 withGhciScript pkgs root $ \dotGhciPath -> do
130166 freePort <- getFreePort
131167 assets <- findProjectAssets root
@@ -138,39 +174,85 @@ run = withProjectRoot "." $ \root -> do
138174 , "Frontend.frontend"
139175 ]
140176
141−runRepl :: MonadObelisk m => m ()
142−runRepl = withProjectRoot "." $ \root -> do
143− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
177+runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
178+runRepl root interpretPaths = do
179+ pkgs <- getParsedLocalPkgs root interpretPaths
144180 withGhciScript pkgs "." $ \dotGhciPath ->
145181 runGhciRepl root pkgs dotGhciPath
146182
147−runWatch :: MonadObelisk m => m ()
148−runWatch = withProjectRoot "." $ \root -> do
149− pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
183+runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
184+runWatch root interpretPaths = do
185+ pkgs <- getParsedLocalPkgs root interpretPaths
150186 withGhciScript pkgs root $ \dotGhciPath ->
151187 runGhcid root True dotGhciPath pkgs Nothing
152188
189+exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
190+exportGhciConfig root interpretPaths = do
191+ pkgs <- getParsedLocalPkgs root interpretPaths
192+ getGhciSessionSettings pkgs "."
193+
194+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
195+nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
196+ pkgs <- getParsedLocalPkgs root interpretPaths
197+ nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
198+
199+-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.
200+getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)
201+getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths
202+
153203-- | Relative paths to local packages of an obelisk project.
154204--
155205-- These are a combination of the obelisk predefined local packages,
156206-- and any packages that the user has set with the @packages@ argument
157207-- to the Nix @project@ function.
158−getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
159−getLocalPkgs root = do
160− obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
208+getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath)
209+getLocalPkgs root interpretPaths = do
210+ putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths
211+ obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
161212
162213 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
163214 -- obelisk project is our own.
164− let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
165− fmap (map (makeRelative ".")) $ runFind $
166− ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
167− <> concat [["-not", "-path", p </> "*"] | p <- ("*" </> attrCacheFileName) : exclusions]
215+ obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $
216+ filter (/= root) $ map takeDirectory obeliskPackagePaths
217+ putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|]
218+ let rootsAndExclusions = calcIntepretFinds "" interpretPaths
219+
220+ fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) ->
221+ let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)
222+ in fmap (Set.fromList . map normalise) $ runFind $
223+ ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
224+ <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]
168225 where
169226 runFind args = do
170227 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
171228 putLog Debug $ T.strip $ T.pack err
172229 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
173230
231+-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions.
232+-- This is used when constructing a set of @find@ commands to run to produce a set of packages
233+-- that matches the user's @--interpret@/@--no-interpret@ settings.
234+calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath)
235+calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0
236+ where
237+ go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do
238+ exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' ->
239+ pure $ Map.singleton parent' children'
240+ deeperFinds <- Map.traverseWithKey go exclusions
241+ pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds)
242+
243+-- | Traverses a 'PathTree' and folds all leaves matching a given predicate.
244+foldPathTreeFor
245+ :: forall m a b. (Applicative m, Monoid b)
246+ => (a -> Bool)
247+ -> FilePath
248+ -> PathTree a
249+ -> (FilePath -> PathTree a -> m b)
250+ -> m b
251+foldPathTreeFor predicate parent children f = case children of
252+ PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children')
253+ PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' ->
254+ foldPathTreeFor predicate (parent </> k) children'' f
255+
174256data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
175257 deriving (Eq, Ord, Show)
176258instance Exception GuessPackageFileError
@@ -271,8 +353,8 @@ parseCabalPackage' pkg = runExceptT $ do
271353 Left (_, errors) ->
272354 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
273355
274−parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
275−parsePackagesOrFail dirs = do
356+parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
357+parsePackagesOrFail dirs' = do
276358 (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
277359 flip fmap (parseCabalPackage dir) $ \case
278360 Just packageInfo
@@ -295,26 +377,29 @@ parsePackagesOrFail dirs = do
295377 pure p
296378
297379 packageInfos <- case NE.nonEmpty $ toList unambiguous of
298− Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
380+ Nothing -> failWith $ T.pack $
381+ "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
299382 Just xs -> pure xs
300383
301384 unless (null pkgDirErrs) $
302385 putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
303386
304387 pure packageInfos
388+ where
389+ dirs = toList dirs'
305390
306−packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
307−packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
391+packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
392+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
308393
309394-- | Create ghci configuration to load the given packages
310395withGhciScript
311− :: MonadObelisk m
312− => [CabalPackageInfo] -- ^ List of packages to load into ghci
396+ :: (MonadObelisk m, Foldable f)
397+ => f CabalPackageInfo -- ^ List of packages to load into ghci
313398 -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
314399 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
315400 -> m ()
316−withGhciScript packageInfos pathBase f = do
317− selfExe <- liftIO getExecutablePath
401+withGhciScript (toList -> packageInfos) pathBase f = do
402+ ghciSettings <- getGhciSessionSettings packageInfos pathBase
318403 let
319404 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
320405 modulesToLoad = mconcat
@@ -323,9 +408,7 @@ withGhciScript packageInfos pathBase f = do
323408 , [ "Frontend" | "frontend" `Set.member` packageNames ]
324409 ]
325410 dotGhci = unlines
326− -- TODO: Shell escape
327− [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
328− , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
411+ [ ":set " <> unwords ghciSettings -- TODO: Shell escape
329412 , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
330413 , "import qualified Obelisk.Run"
331414 , "import qualified Frontend"
@@ -335,33 +418,53 @@ withGhciScript packageInfos pathBase f = do
335418 liftIO $ writeFile dotGhciPath dotGhci
336419 f dotGhciPath
337420
338− where
339− rootedSourceDirs pkg = NE.toList $
340− makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
421+-- | Builds a list of options to pass to ghci or set in .ghci file that configures
422+-- the preprocessor and source includes.
423+getGhciSessionSettings
424+ :: (MonadObelisk m, Foldable f)
425+ => f CabalPackageInfo -- ^ List of packages to load into ghci
426+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
427+ -> m [String]
428+getGhciSessionSettings (toList -> packageInfos) pathBase = do
429+ -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
430+ -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
431+ -- all paths to 'pathBase'.
432+ selfExe <- liftIO $ canonicalizePath =<< getExecutablePath
433+ canonicalPathBase <- liftIO $ canonicalizePath pathBase
434+
435+ (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
436+ canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
437+ canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
438+ pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)
439+
440+ pure
441+ $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
442+ <> concatMap (\p -> ["-optF", p]) pkgFiles
443+ <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
341444
342445-- | Run ghci repl
343446runGhciRepl
344− :: MonadObelisk m
447+ :: (MonadObelisk m, Foldable f)
345448 => FilePath -- ^ Path to project root
346− -> [CabalPackageInfo]
449+ -> f CabalPackageInfo
347450 -> FilePath -- ^ Path to .ghci
348451 -> m ()
349−runGhciRepl root packages dotGhci =
452+runGhciRepl root (toList -> packages) dotGhci =
350453 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
351454 -- ghc that is provided by the shell in the user's project.
352− nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
455+ nixShellWithPkgs root True False (packageInfoToNamePathMap packages) "ghc" $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
353456
354457-- | Run ghcid
355458runGhcid
356− :: MonadObelisk m
459+ :: (MonadObelisk m, Foldable f)
357460 => FilePath -- ^ Path to project root
358461 -> Bool -- ^ Should we chdir to root when running this process?
359462 -> FilePath -- ^ Path to .ghci
360− -> [CabalPackageInfo]
463+ -> f CabalPackageInfo
361464 -> Maybe String -- ^ Optional command to run at every reload
362465 -> m ()
363−runGhcid root chdirToRoot dotGhci packages mcmd =
364− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
466+runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =
467+ nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
365468 where
366469 opts =
367470 [ "-W"
@@ -393,3 +496,11 @@ getFreePort = liftIO $ withSocketsDo $ do
393496 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
394497 bind sock (addrAddress addr)
395498 return sock
499+
500+
501+-- | Convert a 'FilePath' into a 'PathTree'.
502+pathToTree :: a -> FilePath -> PathTree a
503+pathToTree a p = go $ splitDirectories p
504+ where
505+ go [] = PathTree_Node (Just a) mempty
506+ go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs