diff --git a/lib/command/obelisk-command.cabal b/lib/command/obelisk-command.cabal index 0802c6f98..7ab1119fe 100644 --- a/lib/command/obelisk-command.cabal +++ b/lib/command/obelisk-command.cabal @@ -31,6 +31,7 @@ library , megaparsec , modern-uri , monad-loops + , monoidal-containers , mtl , network , network-uri diff --git a/lib/command/src/Obelisk/Command.hs b/lib/command/src/Obelisk/Command.hs index e219530d2..d3e11bd0a 100644 --- a/lib/command/src/Obelisk/Command.hs +++ b/lib/command/src/Obelisk/Command.hs @@ -3,15 +3,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Obelisk.Command where -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bool (bool) import Data.Foldable (for_) import Data.List (isInfixOf, isPrefixOf) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map import qualified Data.Text as T +import Data.Traversable (for) import Options.Applicative import Options.Applicative.Help.Pretty (text, (<$$>)) import System.Directory @@ -81,11 +84,11 @@ initForce = switch (long "force" <> help "Allow ob init to overwrite files") data ObCommand = ObCommand_Init InitSource Bool | ObCommand_Deploy DeployCommand - | ObCommand_Run + | ObCommand_Run [(FilePath, Interpret)] | ObCommand_Profile String [String] | ObCommand_Thunk ThunkOption - | ObCommand_Repl - | ObCommand_Watch + | ObCommand_Repl [(FilePath, Interpret)] + | ObCommand_Watch [(FilePath, Interpret)] | ObCommand_Shell ShellOpts | ObCommand_Doc String [String] -- shell and list of packages | ObCommand_Hoogle String Int -- shell and port @@ -96,6 +99,7 @@ data ObInternal -- the preprocessor argument syntax is also handled outside -- optparse-applicative, but it shouldn't ever conflict with another syntax = ObInternal_ApplyPackages String String String [String] + | ObInternal_ExportGhciConfig [(FilePath, Interpret)] deriving Show obCommand :: ArgsConfig -> Parser ObCommand @@ -103,11 +107,11 @@ obCommand cfg = hsubparser (mconcat [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project" , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project" - , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode" + , command "run" $ info (ObCommand_Run <$> interpretOpts) $ progDesc "Run current project in development mode" , command "profile" $ info (uncurry ObCommand_Profile <$> profileCommand) $ progDesc "Run current project with profiling enabled" , command "thunk" $ info (ObCommand_Thunk <$> thunkOption) $ progDesc "Manipulate thunk directories" - , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter" - , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings" + , command "repl" $ info (ObCommand_Repl <$> interpretOpts) $ progDesc "Open an interactive interpreter" + , command "watch" $ info (ObCommand_Watch <$> interpretOpts) $ progDesc "Watch current project for errors and warnings" , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies" , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $ progDesc "List paths to haddock documentation for specified packages" @@ -115,8 +119,14 @@ obCommand cfg = hsubparser text "Hint: To open the documentation you can pipe the output of this command like" <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open") , command "hoogle" $ info (ObCommand_Hoogle <$> shellFlags <*> portOpt 8080) $ progDesc "Run a hoogle server locally for your project's dependency tree" + , command "internal" $ info (ObCommand_Internal <$> internalCommand) $ progDesc "Internal Obelisk commands with unstable APIs" ]) +internalCommand :: Parser ObInternal +internalCommand = hsubparser $ mconcat + [ command "export-ghci-configuration" $ info (ObInternal_ExportGhciConfig <$> interpretOpts) $ progDesc "Export the GHCi configuration used by ob run, etc.; useful for IDE integration" + ] + packageNames :: Parser [String] packageNames = some (strArgument (metavar "PACKAGE-NAME...")) @@ -237,6 +247,7 @@ thunkOption = hsubparser $ mconcat data ShellOpts = ShellOpts { _shellOpts_shell :: String + , _shellOpts_interpretPaths :: [(FilePath, Interpret)] , _shellOpts_command :: Maybe String } deriving Show @@ -247,9 +258,30 @@ shellFlags = <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc") <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'") +interpretOpts :: Parser [(FilePath, Interpret)] +interpretOpts = many + ( (, Interpret_Interpret) <$> + strOption (common <> long "interpret" <> help + "Don't pre-build packages found in DIR when constructing the package database. The default behavior is \ + \'--interpret ', which will load everything which is unpacked into GHCi. \ + \ Use --interpret and --no-interpret multiple times to add or remove multiple trees \ + \ from the environment. Settings for right-most directories will \ + \ override settings for any identical directories given earlier." + ) + <|> (, Interpret_NoInterpret) <$> + strOption (common <> long "no-interpret" <> help + "Make packages found in DIR available in the package database (but only when they are used dependencies). \ + \ This will build the packages in DIR before loading GHCi. \ + \See help for --interpret for how the two options are related." + ) + ) + where + common = action "directory" <> metavar "DIR" + shellOpts :: Parser ShellOpts shellOpts = ShellOpts <$> shellFlags + <*> interpretOpts <*> optional (strArgument (metavar "COMMAND")) portOpt :: Int -> Parser Int @@ -352,7 +384,7 @@ ob = \case Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg DeployCommand_Update -> deployUpdate "." DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs - ObCommand_Run -> run + ObCommand_Run interpretPathsList -> withInterpretPaths interpretPathsList run ObCommand_Profile basePath rtsFlags -> profile basePath rtsFlags ObCommand_Thunk to -> case _thunkOption_command to of ThunkCommand_Update config -> for_ thunks (updateThunkToLatest config) @@ -361,17 +393,27 @@ ob = \case ThunkCommand_Init -> for_ thunks initThunk where thunks = _thunkOption_thunks to - ObCommand_Repl -> runRepl - ObCommand_Watch -> runWatch - ObCommand_Shell so -> withProjectRoot "." $ \root -> - projectShell root False (_shellOpts_shell so) (_shellOpts_command so) - ObCommand_Doc shell' pkgs -> withProjectRoot "." $ \root -> - projectShell root False shell' (Just $ haddockCommand pkgs) + ObCommand_Repl interpretPathsList -> withInterpretPaths interpretPathsList runRepl + ObCommand_Watch interpretPathsList -> withInterpretPaths interpretPathsList runWatch + ObCommand_Shell (ShellOpts shellAttr interpretPathsList cmd) -> withInterpretPaths interpretPathsList $ \root interpretPaths -> + nixShellForInterpretPaths False shellAttr root interpretPaths cmd + ObCommand_Doc shellAttr pkgs -> withProjectRoot "." $ \root -> + nixShellForInterpretPaths True shellAttr root emptyPathTree $ Just $ haddockCommand pkgs ObCommand_Hoogle shell' port -> withProjectRoot "." $ \root -> do nixShellWithHoogle root True shell' $ Just $ "hoogle server -p " <> show port <> " --local" ObCommand_Internal icmd -> case icmd of ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths + ObInternal_ExportGhciConfig interpretPathsList -> liftIO . putStrLn . unlines =<< withInterpretPaths interpretPathsList exportGhciConfig + +-- | A helper for the common case that the command you want to run needs the project root and a resolved +-- set of interpret paths. +withInterpretPaths :: MonadObelisk m => [(FilePath, Interpret)] -> (FilePath -> PathTree Interpret -> m a) -> m a +withInterpretPaths interpretPathsList f = withProjectRoot "." $ \root -> do + interpretPaths' <- resolveInterpretPaths $ (root, Interpret_Interpret) : interpretPathsList + case interpretPaths' of + Nothing -> failWith "No paths provided for finding packages" + Just interpretPaths -> f root interpretPaths haddockCommand :: [String] -> String haddockCommand pkgs = unwords @@ -385,3 +427,22 @@ haddockCommand pkgs = unwords getArgsConfig :: IO ArgsConfig getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" } + +-- | Resolves an ordered list of paths for use with @--interpret@/@--no-interpret@ by coalescing +-- paths into a non-ambiguous set of paths. Ambiguity is resolved by choosing right-most paths +-- over any preceeding identical paths. +-- +-- For example: @a/b=ON a/b/c=OFF@ and @a/b/c=OFF a/b=ON@ are the same. +-- @a/b=ON a/b=OFF@ is reduced to @a/b=OFF@. We prefer right-biased choice to increase +-- scriptability. +-- +-- N.B. All the paths in the result will be canonicalized. It's impossible to determine path +-- overlap otherwise. +resolveInterpretPaths :: MonadIO m => [(FilePath, a)] -> m (Maybe (PathTree a)) +resolveInterpretPaths ps = do + trees <- liftIO $ for ps $ \(p, a) -> pathToTree a <$> canonicalizePath p + pure $ foldr1 mergeTrees <$> nonEmpty trees + where + -- | Merge two 'PathTree's preferring leaves on the right in as much as they overlap with paths on the left. + mergeTrees :: PathTree a -> PathTree a -> PathTree a + mergeTrees (PathTree_Node ax x) (PathTree_Node ay y) = PathTree_Node (ay <|> ax) $ Map.unionWith mergeTrees x y diff --git a/lib/command/src/Obelisk/Command/Project.hs b/lib/command/src/Obelisk/Command/Project.hs index dd2241170..28adf3048 100644 --- a/lib/command/src/Obelisk/Command/Project.hs +++ b/lib/command/src/Obelisk/Command/Project.hs @@ -12,7 +12,6 @@ module Obelisk.Command.Project , nixShellWithHoogle , nixShellWithPkgs , obeliskDirName - , projectShell , toImplDir , toObeliskDir , withProjectRoot @@ -264,19 +263,20 @@ nixShellRunConfig root isPure command = do nixShellRunProc :: NixShellConfig -> ProcessSpec nixShellRunProc cfg = setDelegateCtlc True $ proc "nix-shell" $ runNixShellConfig cfg -nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> Bool -> Map Text FilePath -> Maybe String -> m () -nixShellWithPkgs root isPure chdirToRoot packageNamesAndPaths command = do +nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> Bool -> Map Text FilePath -> String -> Maybe String -> m () +nixShellWithPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute defShellConfig <- nixShellRunConfig root isPure command let setCwd_ = if chdirToRoot then setCwd (Just root) else id (_, _, _, ph) <- createProcess_ "nixShellWithPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig & nixShellConfig_common . nixCmdConfig_target . target_expr ?~ - "{root, pkgs}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\ + "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\ \shellPackages = builtins.fromJSON pkgs;\ - \})).project.shells.ghc" + \})).project.shells.${shell}" & nixShellConfig_common . nixCmdConfig_args .~ [ rawArg "root" $ toNixPath $ if chdirToRoot then "." else root , strArg "pkgs" (T.unpack $ decodeUtf8 $ BSL.toStrict $ Json.encode packageNamesAndAbsPaths) + , strArg "shell" shellAttr ] void $ waitForProcess ph @@ -291,14 +291,6 @@ nixShellWithHoogle root isPure shell' command = do & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ] void $ waitForProcess ph -projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m () -projectShell root isPure shellName command = do - defShellConfig <- nixShellRunConfig root isPure command - (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig - & nixShellConfig_common . nixCmdConfig_target . target_path ?~ "default.nix" - & nixShellConfig_common . nixCmdConfig_target . target_attr ?~ ("shells." <> shellName) - void $ waitForProcess ph - findProjectAssets :: MonadObelisk m => FilePath -> m Text findProjectAssets root = do isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $ diff --git a/lib/command/src/Obelisk/Command/Run.hs b/lib/command/src/Obelisk/Command/Run.hs index 1ea093555..45276ebd8 100644 --- a/lib/command/src/Obelisk/Command/Run.hs +++ b/lib/command/src/Obelisk/Command/Run.hs @@ -1,9 +1,14 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Obelisk.Command.Run where import Control.Arrow ((&&&)) @@ -15,13 +20,18 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (MonadIO) import Data.Coerce (coerce) import Data.Default (def) -import Data.Either -import Data.Foldable (for_, toList) +import Data.Either (partitionEithers) +import Data.Foldable (fold, for_, toList) +import Data.Functor.Identity (runIdentity) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Map.Monoidal as MMap import Data.Maybe +import Data.Set (Set) import qualified Data.Set as Set +import Data.String.Here.Interpolated (i) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -83,6 +93,34 @@ data CabalPackageInfo = CabalPackageInfo -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file) } +-- | 'Bool' with a better name for it's purpose. +data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show) + +textInterpret :: Interpret -> Text +textInterpret = \case + Interpret_Interpret -> "Interpret" + Interpret_NoInterpret -> "NoInterpret" + +-- | Describe a set of 'FilePath's as a tree to facilitate merging them in a convenient way. +data PathTree a = PathTree_Node + (Maybe a) -- An optional leaf at this point in the tree + (Map FilePath (PathTree a)) -- Branches to deeper leaves + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +emptyPathTree :: PathTree a +emptyPathTree = PathTree_Node Nothing mempty + +-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw. +drawPathTree :: (a -> Text) -> PathTree a -> Text +drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0) + where + annotated ma = maybe id (\a b -> b <> " [" <> showA a <> "]") ma . T.pack + goTree (fp, PathTree_Node ma forest) = annotated ma fp : goForest (Map.toList forest) + goForest [] = [] + goForest [tree] = shift "└─ " " " (goTree tree) + goForest (tree:forest) = shift "├─ " "│ " (goTree tree) <> goForest forest + shift first other = zipWith (<>) (first : repeat other) + -- | Used to signal to obelisk that it's being invoked as a preprocessor preprocessorIdentifier :: String preprocessorIdentifier = "__preprocessor-apply-packages" @@ -121,11 +159,9 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do <> [ "-RTS" ] void $ waitForProcess ph -run - :: MonadObelisk m - => m () -run = withProjectRoot "." $ \root -> do - pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root +run :: MonadObelisk m => FilePath -> PathTree Interpret -> m () +run root interpretPaths = do + pkgs <- getParsedLocalPkgs root interpretPaths withGhciScript pkgs root $ \dotGhciPath -> do freePort <- getFreePort assets <- findProjectAssets root @@ -138,39 +174,85 @@ run = withProjectRoot "." $ \root -> do , "Frontend.frontend" ] -runRepl :: MonadObelisk m => m () -runRepl = withProjectRoot "." $ \root -> do - pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root +runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m () +runRepl root interpretPaths = do + pkgs <- getParsedLocalPkgs root interpretPaths withGhciScript pkgs "." $ \dotGhciPath -> runGhciRepl root pkgs dotGhciPath -runWatch :: MonadObelisk m => m () -runWatch = withProjectRoot "." $ \root -> do - pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root +runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m () +runWatch root interpretPaths = do + pkgs <- getParsedLocalPkgs root interpretPaths withGhciScript pkgs root $ \dotGhciPath -> runGhcid root True dotGhciPath pkgs Nothing +exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String] +exportGhciConfig root interpretPaths = do + pkgs <- getParsedLocalPkgs root interpretPaths + getGhciSessionSettings pkgs "." + +nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m () +nixShellForInterpretPaths isPure shell root interpretPaths cmd = do + pkgs <- getParsedLocalPkgs root interpretPaths + nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd + +-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed. +getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo) +getParsedLocalPkgs root interpretPaths = parsePackagesOrFail =<< getLocalPkgs root interpretPaths + -- | Relative paths to local packages of an obelisk project. -- -- These are a combination of the obelisk predefined local packages, -- and any packages that the user has set with the @packages@ argument -- to the Nix @project@ function. -getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath] -getLocalPkgs root = do - obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"] +getLocalPkgs :: forall m. MonadObelisk m => FilePath -> PathTree Interpret -> m (Set FilePath) +getLocalPkgs root interpretPaths = do + putLog Debug $ [i|Finding packages with root ${root} and interpret paths:|] <> "\n" <> drawPathTree textInterpret interpretPaths + obeliskPackagePaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"] -- We do not want to find packages that are embedded inside other obelisk projects, unless that -- obelisk project is our own. - let exclusions = filter (/= root) $ map takeDirectory obeliskPaths - fmap (map (makeRelative ".")) $ runFind $ - ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"] - <> concat [["-not", "-path", p "*"] | p <- ("*" attrCacheFileName) : exclusions] + obeliskPackageExclusions <- liftIO $ fmap Set.fromList $ traverse canonicalizePath $ + filter (/= root) $ map takeDirectory obeliskPackagePaths + putLog Debug [i|Excluding obelisk packages: ${T.pack $ unwords $ Set.toList obeliskPackageExclusions}|] + let rootsAndExclusions = calcIntepretFinds "" interpretPaths + + fmap fold $ for (MMap.toAscList rootsAndExclusions) $ \(interpretPathRoot, exclusions) -> + let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" attrCacheFileName) + in fmap (Set.fromList . map normalise) $ runFind $ + ["-L", interpretPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"] + <> concat [["-not", "-path", p "*"] | p <- toList allExclusions] where runFind args = do (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args putLog Debug $ T.strip $ T.pack err pure $ map T.unpack $ T.lines $ T.strip $ T.pack out +-- | Calculates a set of root 'FilePath's along with each one's corresponding set of exclusions. +-- This is used when constructing a set of @find@ commands to run to produce a set of packages +-- that matches the user's @--interpret@/@--no-interpret@ settings. +calcIntepretFinds :: FilePath -> PathTree Interpret -> MMap.MonoidalMap FilePath (Set FilePath) +calcIntepretFinds treeRoot0 tree0 = runIdentity $ go treeRoot0 tree0 + where + go treeRoot tree = foldPathTreeFor (== Interpret_Interpret) treeRoot tree $ \parent children -> do + exclusions <- foldPathTreeFor (== Interpret_NoInterpret) parent children $ \parent' children' -> + pure $ Map.singleton parent' children' + deeperFinds <- Map.traverseWithKey go exclusions + pure $ MMap.singleton parent (Map.keysSet exclusions) <> fold (MMap.MonoidalMap deeperFinds) + +-- | Traverses a 'PathTree' and folds all leaves matching a given predicate. +foldPathTreeFor + :: forall m a b. (Applicative m, Monoid b) + => (a -> Bool) + -> FilePath + -> PathTree a + -> (FilePath -> PathTree a -> m b) + -> m b +foldPathTreeFor predicate parent children f = case children of + PathTree_Node (Just x) children' | predicate x -> f parent (PathTree_Node Nothing children') + PathTree_Node _ children' -> fmap fold $ flip Map.traverseWithKey children' $ \k children'' -> + foldPathTreeFor predicate (parent k) children'' f + data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound deriving (Eq, Ord, Show) instance Exception GuessPackageFileError @@ -271,8 +353,8 @@ parseCabalPackage' pkg = runExceptT $ do Left (_, errors) -> throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors) -parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo) -parsePackagesOrFail dirs = do +parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo) +parsePackagesOrFail dirs' = do (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do flip fmap (parseCabalPackage dir) $ \case Just packageInfo @@ -295,26 +377,29 @@ parsePackagesOrFail dirs = do pure p packageInfos <- case NE.nonEmpty $ toList unambiguous of - Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs + Nothing -> failWith $ T.pack $ + "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs) Just xs -> pure xs unless (null pkgDirErrs) $ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs pure packageInfos + where + dirs = toList dirs' -packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath -packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) +packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath +packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList -- | Create ghci configuration to load the given packages withGhciScript - :: MonadObelisk m - => [CabalPackageInfo] -- ^ List of packages to load into ghci + :: (MonadObelisk m, Foldable f) + => f CabalPackageInfo -- ^ List of packages to load into ghci -> FilePath -- ^ All paths written to the .ghci file will be relative to this path -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci -> m () -withGhciScript packageInfos pathBase f = do - selfExe <- liftIO getExecutablePath +withGhciScript (toList -> packageInfos) pathBase f = do + ghciSettings <- getGhciSessionSettings packageInfos pathBase let packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos modulesToLoad = mconcat @@ -323,9 +408,7 @@ withGhciScript packageInfos pathBase f = do , [ "Frontend" | "frontend" `Set.member` packageNames ] ] dotGhci = unlines - -- TODO: Shell escape - [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos) - , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs) + [ ":set " <> unwords ghciSettings -- TODO: Shell escape , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad , "import qualified Obelisk.Run" , "import qualified Frontend" @@ -335,33 +418,53 @@ withGhciScript packageInfos pathBase f = do liftIO $ writeFile dotGhciPath dotGhci f dotGhciPath - where - rootedSourceDirs pkg = NE.toList $ - makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg ) <$> _cabalPackageInfo_sourceDirs pkg +-- | Builds a list of options to pass to ghci or set in .ghci file that configures +-- the preprocessor and source includes. +getGhciSessionSettings + :: (MonadObelisk m, Foldable f) + => f CabalPackageInfo -- ^ List of packages to load into ghci + -> FilePath -- ^ All paths written to the .ghci file will be relative to this path + -> m [String] +getGhciSessionSettings (toList -> packageInfos) pathBase = do + -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that + -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize + -- all paths to 'pathBase'. + selfExe <- liftIO $ canonicalizePath =<< getExecutablePath + canonicalPathBase <- liftIO $ canonicalizePath pathBase + + (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do + canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg ) <$> _cabalPackageInfo_sourceDirs pkg + canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg + pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs) + + pure + $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier] + <> concatMap (\p -> ["-optF", p]) pkgFiles + <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ] -- | Run ghci repl runGhciRepl - :: MonadObelisk m + :: (MonadObelisk m, Foldable f) => FilePath -- ^ Path to project root - -> [CabalPackageInfo] + -> f CabalPackageInfo -> FilePath -- ^ Path to .ghci -> m () -runGhciRepl root packages dotGhci = +runGhciRepl root (toList -> packages) dotGhci = -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the -- ghc that is provided by the shell in the user's project. - nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape + nixShellWithPkgs root True False (packageInfoToNamePathMap packages) "ghc" $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape -- | Run ghcid runGhcid - :: MonadObelisk m + :: (MonadObelisk m, Foldable f) => FilePath -- ^ Path to project root -> Bool -- ^ Should we chdir to root when running this process? -> FilePath -- ^ Path to .ghci - -> [CabalPackageInfo] + -> f CabalPackageInfo -> Maybe String -- ^ Optional command to run at every reload -> m () -runGhcid root chdirToRoot dotGhci packages mcmd = - nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape +runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd = + nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape where opts = [ "-W" @@ -393,3 +496,11 @@ getFreePort = liftIO $ withSocketsDo $ do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) bind sock (addrAddress addr) return sock + + +-- | Convert a 'FilePath' into a 'PathTree'. +pathToTree :: a -> FilePath -> PathTree a +pathToTree a p = go $ splitDirectories p + where + go [] = PathTree_Node (Just a) mempty + go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs