git.iko.soy/obelisk
on master help sign in
command: Use custom shell for ob run/repl based on local packages
9e6093fElliot Cameron
lib/command/src/Obelisk/Command/Project.hs+39−15
compare with master
unifiedsplit
@@ -3,25 +3,27 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Obelisk.Command.Project
4module Obelisk.Command.Project
5 ( InitSource (..)
5 ( InitSource (..)
6− , initProject
7 , findProjectObeliskCommand
6 , findProjectObeliskCommand
8 , findProjectRoot
7 , findProjectRoot
9− , withProjectRoot
8+ , initProject
10− , inProjectShell
9+ , nixShellWithPkgs
11− , inImpureProjectShell
12− , projectShell
13−
14 , obeliskDirName
10 , obeliskDirName
15− , toObeliskDir
11+ , projectShell
16 , toImplDir
12 , toImplDir
13+ , toNixPath
14+ , toObeliskDir
15+ , withProjectRoot
17 ) where
16 ) where
18
17
19import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
18import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
19+import Control.Lens ((.~), (?~), (<&>))
20import Control.Monad
20import Control.Monad
21import Control.Monad.IO.Class (liftIO)
21import Control.Monad.IO.Class (liftIO)
22import Control.Monad.State
22import Control.Monad.State
23import Data.Bits
23import Data.Bits
24−import Data.Function (on)
24+import Data.Default (def)
25+import Data.Function ((&), on)
26+import Data.List (isInfixOf)
25import qualified Data.Text as T
27import qualified Data.Text as T
26import System.Directory
28import System.Directory
27import System.Environment (lookupEnv)
29import System.Environment (lookupEnv)
@@ -37,6 +39,7 @@ import GitHub.Data.Name (Name)
37
39
38import Obelisk.App (MonadObelisk)
40import Obelisk.App (MonadObelisk)
39import Obelisk.CliApp
41import Obelisk.CliApp
42+import Obelisk.Command.Nix
40import Obelisk.Command.Thunk
43import Obelisk.Command.Thunk
41import Obelisk.Command.Utils (nixExePath)
44import Obelisk.Command.Utils (nixExePath)
42
45
@@ -237,14 +240,35 @@ filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= uma
237 fileGroupWritable = fileMode s .&. 0o020 == 0o020
240 fileGroupWritable = fileMode s .&. 0o020 == 0o020
238 umaskGroupWritable = umask .&. 0o020 == 0
241 umaskGroupWritable = umask .&. 0o020 == 0
239
242
240−-- | Run a command in the given shell for the current project
243+-- nix-shell -E '{ root, shell-pkgs }: ((import root {}).passthru.self.extend (self: super: { shells-ghc = shell-pkgs; })).project.shells.ghc' --arg root ./. --arg shell-pkgs '["backend"]'
241−inProjectShell :: MonadObelisk m => String -> String -> m ()
244+
242−inProjectShell shellName command = withProjectRoot "." $ \root ->
245+-- | Nix syntax requires relative paths to be prefixed by @./@ or
243− projectShell root True shellName (Just command)
246+-- @../@. This will make a 'FilePath' that can be embedded in a Nix
247+-- expression.
248+toNixPath :: FilePath -> FilePath
249+toNixPath root | "/" `isInfixOf` root = root
250+ | otherwise = "./" <> root
251+
244
252
245−inImpureProjectShell :: MonadObelisk m => String -> String -> m ()
253+nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> [String] -> Maybe String -> m ()
246−inImpureProjectShell shellName command = withProjectRoot "." $ \root ->
254+nixShellWithPkgs root isPure packageNames command = do
247− projectShell root False shellName (Just command)
255+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $
256+ proc nixExePath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]
257+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"
258+ (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setDelegateCtlc True $ setCwd (Just root) $ proc "nix-shell" $
259+ runNixShellConfig $ def
260+ & nixShellConfig_pure .~ isPure
261+ & nixShellConfig_common . nixCmdConfig_target .~ (def
262+ & target_path .~ Nothing
263+ & target_expr ?~ "{ root, shell-pkgs }: ((import root {}).passthru.self.extend (self: super: { shells-ghc = shell-pkgs; })).project.shells.ghc"
264+ )
265+ & nixShellConfig_common . nixCmdConfig_args .~ [rawArg "root" $ toNixPath root, rawArg "shell-pkgs" ("[" <> unwords (map show packageNames) <> "]")]
266+ & nixShellConfig_run .~ (command <&> \c -> mconcat
267+ [ "export NIX_PATH=nixpkgs=", T.unpack nixpkgsPath, "; "
268+ , maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote
269+ , c
270+ ])
271+ void $ liftIO $ waitForProcess ph
248
272
249projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
273projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
250projectShell root isPure shellName command = do
274projectShell root isPure shellName command = do
lib/command/src/Obelisk/Command/Run.hs+44−35
@@ -7,16 +7,17 @@
7module Obelisk.Command.Run where
7module Obelisk.Command.Run where
8
8
9import Control.Exception (Exception, bracket)
9import Control.Exception (Exception, bracket)
10−import Control.Monad (filterM, unless, when)
10+import Control.Monad (filterM, unless)
11import Control.Monad.Except (runExceptT, throwError)
11import Control.Monad.Except (runExceptT, throwError)
12import Control.Monad.IO.Class (liftIO)
12import Control.Monad.IO.Class (liftIO)
13import Control.Monad.Reader (MonadIO)
13import Control.Monad.Reader (MonadIO)
14import Data.Coerce (coerce)
14import Data.Coerce (coerce)
15import Data.Either
15import Data.Either
16−import Data.Foldable (for_)
16+import Data.Foldable (for_, toList)
17import Data.List.Extra (dropPrefix)
17import Data.List.Extra (dropPrefix)
18import qualified Data.List.NonEmpty as NE
18import qualified Data.List.NonEmpty as NE
19import Data.Maybe
19import Data.Maybe
20+import qualified Data.Set as Set
20import qualified Data.Text as T
21import qualified Data.Text as T
21import Data.Traversable (for)
22import Data.Traversable (for)
22import Debug.Trace (trace)
23import Debug.Trace (trace)
@@ -43,7 +44,7 @@ import System.IO.Temp (withSystemTempDirectory)
43
44
44import Obelisk.App (MonadObelisk)
45import Obelisk.App (MonadObelisk)
45import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
46import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
46−import Obelisk.Command.Project (inProjectShell, obeliskDirName, toObeliskDir, withProjectRoot)
47+import Obelisk.Command.Project (obeliskDirName, toObeliskDir, withProjectRoot, nixShellWithPkgs, toNixPath)
47import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
48import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
48
49
49data CabalPackageInfo = CabalPackageInfo
50data CabalPackageInfo = CabalPackageInfo
@@ -66,7 +67,7 @@ preprocessorIdentifier = "__preprocessor-apply-packages"
66
67
67run :: MonadObelisk m => m ()
68run :: MonadObelisk m => m ()
68run = withProjectRoot "." $ \root -> do
69run = withProjectRoot "." $ \root -> do
69− pkgs <- getLocalPkgs root
70+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
70 withGhciScript pkgs $ \dotGhciPath -> do
71 withGhciScript pkgs $ \dotGhciPath -> do
71 freePort <- getFreePort
72 freePort <- getFreePort
72 assets <- do
73 assets <- do
@@ -91,7 +92,7 @@ run = withProjectRoot "." $ \root -> do
91 else readProcessAndLogStderr Debug $
92 else readProcessAndLogStderr Debug $
92 proc nixExePath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
93 proc nixExePath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
93 putLog Debug $ "Assets impurely loaded from: " <> assets
94 putLog Debug $ "Assets impurely loaded from: " <> assets
94− runGhcid dotGhciPath $ Just $ unwords
95+ runGhcid dotGhciPath pkgs $ Just $ unwords
95 [ "Obelisk.Run.run"
96 [ "Obelisk.Run.run"
96 , show freePort
97 , show freePort
97 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
98 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -99,30 +100,23 @@ run = withProjectRoot "." $ \root -> do
99 , "Frontend.frontend"
100 , "Frontend.frontend"
100 ]
101 ]
101
102
102−-- | Nix syntax requires relative paths to be prefixed by @./@ or
103−-- @../@. This will make a 'FilePath' that can be embedded in a Nix
104−-- expression.
105−toNixPath :: FilePath -> FilePath
106−toNixPath root | "/" `isInfixOf` root = root
107− | otherwise = "./" <> root
108−
109runRepl :: MonadObelisk m => m ()
103runRepl :: MonadObelisk m => m ()
110runRepl = do
104runRepl = do
111− pkgs <- withProjectRoot "." getLocalPkgs
105+ pkgs <- fmap toList . parsePackagesOrFail =<< withProjectRoot "." getLocalPkgs
112 withGhciScript pkgs $ \dotGhciPath -> do
106 withGhciScript pkgs $ \dotGhciPath -> do
113− runGhciRepl dotGhciPath
107+ runGhciRepl pkgs dotGhciPath
114
108
115runWatch :: MonadObelisk m => m ()
109runWatch :: MonadObelisk m => m ()
116runWatch = do
110runWatch = do
117− pkgs <- withProjectRoot "." getLocalPkgs
111+ pkgs <- fmap toList . parsePackagesOrFail =<< withProjectRoot "." getLocalPkgs
118− withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
112+ withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath pkgs Nothing
119
113
120-- | Relative paths to local packages of an obelisk project.
114-- | Relative paths to local packages of an obelisk project.
121--
115--
122-- These are a combination of the obelisk predefined local packages,
116-- These are a combination of the obelisk predefined local packages,
123-- and any packages that the user has set with the @packages@ argument
117-- and any packages that the user has set with the @packages@ argument
124-- to the Nix @project@ function.
118-- to the Nix @project@ function.
125−getLocalPkgs :: (MonadObelisk m, MonadIO m) => FilePath -> m [FilePath]
119+getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
126getLocalPkgs root = do
120getLocalPkgs root = do
127 (_exitCode, out, err) <- readCreateProcessWithExitCode $
121 (_exitCode, out, err) <- readCreateProcessWithExitCode $
128 proc findExePath ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
122 proc findExePath ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
@@ -233,33 +227,42 @@ parseCabalPackage' pkg = runExceptT $ do
233 Left (_, errors) ->
227 Left (_, errors) ->
234 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
228 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
235
229
236−-- | Create ghci configuration to load the given packages
230+parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
237−withGhciScript
231+parsePackagesOrFail dirs = do
238− :: MonadObelisk m
239− => [FilePath] -- ^ List of packages to load into ghci
240− -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
241− -> m ()
242−withGhciScript dirs f = do
243− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ for dirs $ \dir -> do
232+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
244 flip fmap (parseCabalPackage dir) $ \case
233 flip fmap (parseCabalPackage dir) $ \case
245 Nothing -> Left dir
234 Nothing -> Left dir
246 Just packageInfo -> Right packageInfo
235 Just packageInfo -> Right packageInfo
247
236
248− when (null packageInfos) $
237+ packageInfos <- case NE.nonEmpty packageInfos' of
249− failWith $ T.pack $ "No valid packages found in " <> intercalate ", " dirs
238+ Nothing -> failWith $ T.pack $ "No valid packages found in " <> intercalate ", " dirs
239+ Just xs -> pure xs
240+
250 unless (null pkgDirErrs) $
241 unless (null pkgDirErrs) $
251 putLog Warning $ T.pack $ "Failed to find packages in " <> intercalate ", " pkgDirErrs
242 putLog Warning $ T.pack $ "Failed to find packages in " <> intercalate ", " pkgDirErrs
252
243
244+ pure packageInfos
245+
246+-- | Create ghci configuration to load the given packages
247+withGhciScript
248+ :: MonadObelisk m
249+ => [CabalPackageInfo] -- ^ List of packages to load into ghci
250+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
251+ -> m ()
252+withGhciScript packageInfos f = do
253 selfExe <- liftIO getExecutablePath
253 selfExe <- liftIO getExecutablePath
254 let
254 let
255− packageNames = map _cabalPackageInfo_packageName packageInfos
255+ packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
256+ modulesToLoad = mconcat
257+ [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
258+ , [ "Backend" | "backend" `Set.member` packageNames ]
259+ , [ "Frontend" | "frontend" `Set.member` packageNames ]
260+ ]
256 dotGhci = unlines
261 dotGhci = unlines
257 -- TODO: Shell escape
262 -- TODO: Shell escape
258 [ ":set -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
263 [ ":set -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . _cabalPackageInfo_packageRoot) packageInfos)
259 , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
264 , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
260− , ":load Backend Frontend"
265+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
261− -- We need to also load 'Obelisk.Run' if it's part of our ghci session.
262− <> if "obelisk-run" `elem` packageNames then " Obelisk.Run" else ""
263 , "import qualified Obelisk.Run"
266 , "import qualified Obelisk.Run"
264 , "import qualified Frontend"
267 , "import qualified Frontend"
265 , "import qualified Backend"
268 , "import qualified Backend"
@@ -276,21 +279,27 @@ withGhciScript dirs f = do
276-- | Run ghci repl
279-- | Run ghci repl
277runGhciRepl
280runGhciRepl
278 :: MonadObelisk m
281 :: MonadObelisk m
282+ => [CabalPackageInfo]
279− => FilePath -- ^ Path to .ghci
283+ -> FilePath -- ^ Path to .ghci
280 -> m ()
284 -> m ()
281−runGhciRepl dotGhci =
285+runGhciRepl packages dotGhci = withProjectRoot "." $ \root ->
282 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
286 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
283 -- ghc that is provided by the shell in the user's project.
287 -- ghc that is provided by the shell in the user's project.
284− inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci
288+ nixShellWithPkgs root True packageNames $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
289+ where
290+ packageNames = map (T.unpack . _cabalPackageInfo_packageName) packages
285
291
286-- | Run ghcid
292-- | Run ghcid
287runGhcid
293runGhcid
288 :: MonadObelisk m
294 :: MonadObelisk m
289 => FilePath -- ^ Path to .ghci
295 => FilePath -- ^ Path to .ghci
296+ -> [CabalPackageInfo]
290 -> Maybe String -- ^ Optional command to run at every reload
297 -> Maybe String -- ^ Optional command to run at every reload
291 -> m ()
298 -> m ()
299+runGhcid dotGhci packages mcmd = withProjectRoot "." $ \root ->
292−runGhcid dotGhci mcmd = inProjectShell "ghc" $ unwords $ ghcidExePath : opts -- TODO: Shell escape
300+ nixShellWithPkgs root True packageNames (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
293 where
301 where
302+ packageNames = map (T.unpack . _cabalPackageInfo_packageName) packages
294 opts =
303 opts =
295 [ "-W"
304 [ "-W"
296 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
305 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user