IDE compatibility

lib/command/obelisk-command.cabal

@@ -31,6 +31,7 @@ library
     , megaparsec
     , modern-uri
     , monad-loops
+    , monoidal-containers
     , mtl
     , network
     , network-uri

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,27 +99,34 @@ 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
 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"
         <> footerDoc (Just $
               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 <project-root>', 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

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) $