73e78ee · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge pull request #706 from obsidiansystems/eac@improve-ghci-handling

73e78eeElliot Cameron6 years ago

lib/command/src/Obelisk/Command/Project.hs+12−4

compare with master

unifiedsplit

@@ -10,7 +10,7 @@ module Obelisk.Command.Project

10 , nixShellRunConfig

11 , nixShellRunProc

12 , nixShellWithHoogle

13− , nixShellWithPkgs

13+ , nixShellWithoutPkgs

14 , obeliskDirName

15 , toImplDir

16 , toObeliskDir

@@ -287,12 +287,20 @@ nixShellRunConfig root isPure command = do

287nixShellRunProc :: NixShellConfig -> ProcessSpec

288nixShellRunProc cfg = setDelegateCtlc True $ proc "nix-shell" $ runNixShellConfig cfg

289

290−nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> Bool -> Map Text FilePath -> String -> Maybe String -> m ()

290+nixShellWithoutPkgs

291+ :: MonadObelisk m

292+ => FilePath -- ^ Path to project root

293+ -> Bool -- ^ Should this be a pure shell?

294+ -> Bool -- ^ Should we chdir to the package root in the shell?

295+ -> Map Text FilePath -- ^ Package names mapped to their paths

296+ -> String -- ^ Shell attribute to use (e.g. @"ghc"@, @"ghcjs"@, etc.)

297+ -> Maybe String -- ^ If 'Just' run the given command; otherwise just open the interactive shell

298+ -> m ()

291−nixShellWithPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do

299+nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do

292 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute

300 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute

293 defShellConfig <- nixShellRunConfig root isPure command

301 defShellConfig <- nixShellRunConfig root isPure command

294 let setCwd_ = if chdirToRoot then setCwd (Just root) else id

302 let setCwd_ = if chdirToRoot then setCwd (Just root) else id

295− (_, _, _, ph) <- createProcess_ "nixShellWithPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig

303+ (_, _, _, ph) <- createProcess_ "nixShellWithoutPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig

296 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

304 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

297 "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\

305 "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\

298 \shellPackages = builtins.fromJSON pkgs;\

306 \shellPackages = builtins.fromJSON pkgs;\

lib/command/src/Obelisk/Command/Run.hs+73−39

@@ -18,6 +18,8 @@ import Control.Monad (filterM, unless, void)

18import Control.Monad.Except (runExceptT, throwError)

19import Control.Monad.IO.Class (liftIO)

20import Control.Monad.Reader (MonadIO)

21+import Data.Bifoldable (bifoldr1)

22+import Data.Bifunctor (bimap)

21import Data.Coerce (coerce)

23import Data.Coerce (coerce)

22import Data.Default (def)

24import Data.Default (def)

23import Data.Either (partitionEithers)

25import Data.Either (partitionEithers)

@@ -74,7 +76,7 @@ import Obelisk.CliApp (

74 withSpinner,

76 withSpinner,

75 )

77 )

76import Obelisk.Command.Nix

78import Obelisk.Command.Nix

77−import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)

79+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)

78import Obelisk.Command.Thunk (attrCacheFileName)

80import Obelisk.Command.Thunk (attrCacheFileName)

79import Obelisk.Command.Utils (findExePath, ghcidExePath)

81import Obelisk.Command.Utils (findExePath, ghcidExePath)

@@ -162,11 +164,12 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do

162run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

164run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

163run root interpretPaths = do

165run root interpretPaths = do

164 pkgs <- getParsedLocalPkgs root interpretPaths

166 pkgs <- getParsedLocalPkgs root interpretPaths

165− withGhciScript pkgs root $ \dotGhciPath -> do

167+ withGhciScript pkgs $ \dotGhciPath -> do

166− freePort <- getFreePort

167 assets <- findProjectAssets root

168 assets <- findProjectAssets root

168 putLog Debug $ "Assets impurely loaded from: " <> assets

169 putLog Debug $ "Assets impurely loaded from: " <> assets

170+ ghciArgs <- getGhciSessionSettings pkgs root

171+ freePort <- getFreePort

169− runGhcid root True dotGhciPath pkgs $ Just $ unwords

172+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords

170 [ "Obelisk.Run.run"

173 [ "Obelisk.Run.run"

171 , show freePort

174 , show freePort

172 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"

175 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"

@@ -177,14 +180,16 @@ run root interpretPaths = do

177runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

180runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

178runRepl root interpretPaths = do

181runRepl root interpretPaths = do

179 pkgs <- getParsedLocalPkgs root interpretPaths

182 pkgs <- getParsedLocalPkgs root interpretPaths

180− withGhciScript pkgs "." $ \dotGhciPath ->

183+ ghciArgs <- getGhciSessionSettings pkgs "."

184+ withGhciScript pkgs $ \dotGhciPath ->

181− runGhciRepl root pkgs dotGhciPath

185+ runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)

182

186

183runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

187runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()

184runWatch root interpretPaths = do

188runWatch root interpretPaths = do

185 pkgs <- getParsedLocalPkgs root interpretPaths

189 pkgs <- getParsedLocalPkgs root interpretPaths

190+ ghciArgs <- getGhciSessionSettings pkgs root

186− withGhciScript pkgs root $ \dotGhciPath ->

191+ withGhciScript pkgs $ \dotGhciPath ->

187− runGhcid root True dotGhciPath pkgs Nothing

192+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing

188

193

189exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]

194exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]

190exportGhciConfig root interpretPaths = do

195exportGhciConfig root interpretPaths = do

@@ -194,7 +199,7 @@ exportGhciConfig root interpretPaths = do

194nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()

199nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()

195nixShellForInterpretPaths isPure shell root interpretPaths cmd = do

200nixShellForInterpretPaths isPure shell root interpretPaths cmd = do

196 pkgs <- getParsedLocalPkgs root interpretPaths

201 pkgs <- getParsedLocalPkgs root interpretPaths

197− nixShellWithPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd

202+ nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd

198

203

199-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.

204-- | Like 'getLocalPkgs' but also parses them and fails if any of them can't be parsed.

200getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)

205getParsedLocalPkgs :: MonadObelisk m => FilePath -> PathTree Interpret -> m (NonEmpty CabalPackageInfo)

@@ -395,12 +400,14 @@ packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&&

395withGhciScript

400withGhciScript

396 :: (MonadObelisk m, Foldable f)

401 :: (MonadObelisk m, Foldable f)

397 => f CabalPackageInfo -- ^ List of packages to load into ghci

402 => f CabalPackageInfo -- ^ List of packages to load into ghci

398− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path

399 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci

403 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci

400 -> m ()

404 -> m ()

401−withGhciScript (toList -> packageInfos) pathBase f = do

405+withGhciScript (toList -> packageInfos) f =

402− ghciSettings <- getGhciSessionSettings packageInfos pathBase

406+ withSystemTempDirectory "ob-ghci" $ \fp -> do

403− let

407+ let dotGhciPath = fp </> ".ghci"

408+ liftIO $ writeFile dotGhciPath dotGhci

409+ f dotGhciPath

410+ where

404 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos

411 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos

405 modulesToLoad = mconcat

412 modulesToLoad = mconcat

406 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]

413 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]

@@ -408,22 +415,18 @@ withGhciScript (toList -> packageInfos) pathBase f = do

408 , [ "Frontend" | "frontend" `Set.member` packageNames ]

415 , [ "Frontend" | "frontend" `Set.member` packageNames ]

409 ]

416 ]

410 dotGhci = unlines

417 dotGhci = unlines

411− [ ":set " <> unwords ghciSettings -- TODO: Shell escape

412− , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad

418+ [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad

413 , "import qualified Obelisk.Run"

419 , "import qualified Obelisk.Run"

414 , "import qualified Frontend"

420 , "import qualified Frontend"

415− , "import qualified Backend" ]

421+ , "import qualified Backend"

416− withSystemTempDirectory "ob-ghci" $ \fp -> do

422+ ]

417− let dotGhciPath = fp </> ".ghci"

418− liftIO $ writeFile dotGhciPath dotGhci

419− f dotGhciPath

420

423

421-- | Builds a list of options to pass to ghci or set in .ghci file that configures

424-- | Builds a list of options to pass to ghci or set in .ghci file that configures

422-- the preprocessor and source includes.

425-- the preprocessor and source includes.

423getGhciSessionSettings

426getGhciSessionSettings

424 :: (MonadObelisk m, Foldable f)

427 :: (MonadObelisk m, Foldable f)

425 => f CabalPackageInfo -- ^ List of packages to load into ghci

428 => f CabalPackageInfo -- ^ List of packages to load into ghci

426− -> FilePath -- ^ All paths written to the .ghci file will be relative to this path

429+ -> FilePath -- ^ All paths will be relative to this path

427 -> m [String]

430 -> m [String]

428getGhciSessionSettings (toList -> packageInfos) pathBase = do

431getGhciSessionSettings (toList -> packageInfos) pathBase = do

429 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that

432 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that

@@ -435,57 +438,62 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do

435 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do

438 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do

436 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg

439 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg

437 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg

440 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg

438− pure (makeRelative canonicalPathBase canonicalPkgFile, makeRelative canonicalPathBase <$> canonicalSrcDirs)

441+ pure (canonicalPkgFile `relativeTo` canonicalPathBase, (`relativeTo` canonicalPathBase) <$> canonicalSrcDirs)

439

442

440 pure

443 pure

444+ $ baseGhciOptions

441− $ ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]

445+ <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]

442 <> concatMap (\p -> ["-optF", p]) pkgFiles

446 <> concatMap (\p -> ["-optF", p]) pkgFiles

443 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]

447 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]

444

448

449+baseGhciOptions :: [String]

450+baseGhciOptions =

451+ [ "-ignore-dot-ghci"

452+ , "-no-user-package-db"

453+ , "-package-env", "-"

454+ ]

455+

445-- | Run ghci repl

456-- | Run ghci repl

446runGhciRepl

457runGhciRepl

447 :: (MonadObelisk m, Foldable f)

458 :: (MonadObelisk m, Foldable f)

448 => FilePath -- ^ Path to project root

459 => FilePath -- ^ Path to project root

449− -> f CabalPackageInfo

460+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt

450− -> FilePath -- ^ Path to .ghci

461+ -> [String] -- ^ GHCi arguments

451 -> m ()

462 -> m ()

452−runGhciRepl root (toList -> packages) dotGhci =

463+runGhciRepl root (toList -> packages) ghciArgs =

453 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the

464 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the

454 -- ghc that is provided by the shell in the user's project.

465 -- ghc that is provided by the shell in the user's project.

455− nixShellWithPkgs root True False (packageInfoToNamePathMap packages) "ghc" $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape

466+ nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $

467+ Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape

456

468

457-- | Run ghcid

469-- | Run ghcid

458runGhcid

470runGhcid

459 :: (MonadObelisk m, Foldable f)

471 :: (MonadObelisk m, Foldable f)

460 => FilePath -- ^ Path to project root

472 => FilePath -- ^ Path to project root

461 -> Bool -- ^ Should we chdir to root when running this process?

473 -> Bool -- ^ Should we chdir to root when running this process?

462− -> FilePath -- ^ Path to .ghci

474+ -> [String] -- ^ GHCi arguments

463− -> f CabalPackageInfo

475+ -> f CabalPackageInfo -- ^ Packages to keep unbuilt

464 -> Maybe String -- ^ Optional command to run at every reload

476 -> Maybe String -- ^ Optional command to run at every reload

465 -> m ()

477 -> m ()

466−runGhcid root chdirToRoot dotGhci (toList -> packages) mcmd =

478+runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =

467− nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape

479+ nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $

480+ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape

468 where

481 where

469 opts =

482 opts =

470 [ "-W"

483 [ "-W"

471− , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "

472 , "--outputfile=ghcid-output.txt"

484 , "--outputfile=ghcid-output.txt"

473 ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles

485 ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles

474 <> map (\x -> "--restart='" <> x <> "'") restartFiles

486 <> map (\x -> "--restart='" <> x <> "'") restartFiles

475 <> testCmd

487 <> testCmd

488+ <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape

476 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape

489 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape

477

490

478 adjustRoot x = if chdirToRoot then makeRelative root x else x

491 adjustRoot x = if chdirToRoot then makeRelative root x else x

479 reloadFiles = map adjustRoot [root </> "config"]

492 reloadFiles = map adjustRoot [root </> "config"]

480 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages

493 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages

481

494

482−makeBaseGhciOptions :: FilePath -> String

495+mkGhciScriptArg :: FilePath -> [String]

483−makeBaseGhciOptions dotGhci =

484− unwords

485− [ "-no-user-package-db"

486− , "-package-env -"

487− , "-ghci-script " <> dotGhci

496+mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]

488− ]

489

497

490getFreePort :: MonadIO m => m PortNumber

498getFreePort :: MonadIO m => m PortNumber

491getFreePort = liftIO $ withSocketsDo $ do

499getFreePort = liftIO $ withSocketsDo $ do

@@ -504,3 +512,29 @@ pathToTree a p = go $ splitDirectories p

504 where

512 where

505 go [] = PathTree_Node (Just a) mempty

513 go [] = PathTree_Node (Just a) mempty

506 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs

514 go (x : xs) = PathTree_Node Nothing $ Map.singleton x $ go xs

515+

516+-- | Like 'zipWith' but pads with a padding value instead of stopping on the shortest list.

517+zipDefaultWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]

518+zipDefaultWith _da _db _f [] [] = []

519+zipDefaultWith da db f (a:as) [] = f a db : zipDefaultWith da db f as []

520+zipDefaultWith da db f [] (b:bs) = f da b : zipDefaultWith da db f [] bs

521+zipDefaultWith da db f (a:as) (b:bs) = f a b : zipDefaultWith da db f as bs

522+

523+-- | Makes the first absolute path relative to the second absolute path.

524+--

525+-- Both input paths MUST be absolute.

526+--

527+-- Unlike 'makeRelative' this does not merely strip prefixes. It will introduce

528+-- enough @..@ paths to make the resulting path truly relative in virtually every

529+-- case. The only exception is on Windows when the two paths are on different

530+-- drives. In this case the resulting path may be absolute.

531+relativeTo :: FilePath -> FilePath -> FilePath

532+relativeTo dir base

533+ = bifoldr1 (</>)

534+ $ bimap (collapse . (".." <$) . catMaybes) (collapse . catMaybes)

535+ $ unzip

536+ $ dropWhile (\(a,b) -> a == b)

537+ $ zipDefaultWith Nothing Nothing (,)

538+ (map Just $ splitDirectories base)

539+ (map Just $ splitDirectories dir)

540+ where collapse = foldr (</>) ""