6d896e1 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

command: Allow export-ghci-config to decide whether or not to use relative paths

6d896e1Elliot Cameron6 years ago

lib/command/src/Obelisk/Command.hs+9−3

compare with master

unifiedsplit

@@ -99,7 +99,9 @@ data ObInternal

99 -- the preprocessor argument syntax is also handled outside

100 -- optparse-applicative, but it shouldn't ever conflict with another syntax

101 = ObInternal_ApplyPackages String String String [String]

102− | ObInternal_ExportGhciConfig [(FilePath, Interpret)]

102+ | ObInternal_ExportGhciConfig

103+ [(FilePath, Interpret)]

104+ Bool -- ^ Use relative paths

103 deriving Show

105 deriving Show

104

106

105obCommand :: ArgsConfig -> Parser ObCommand

107obCommand :: ArgsConfig -> Parser ObCommand

@@ -124,8 +126,11 @@ obCommand cfg = hsubparser

124

126

125internalCommand :: Parser ObInternal

127internalCommand :: Parser ObInternal

126internalCommand = hsubparser $ mconcat

128internalCommand = hsubparser $ mconcat

129+ [ command "export-ghci-configuration" $ info (ObInternal_ExportGhciConfig <$> interpretOpts <*> useRelativePathsFlag)

127− [ command "export-ghci-configuration" $ info (ObInternal_ExportGhciConfig <$> interpretOpts) $ progDesc "Export the GHCi configuration used by ob run, etc.; useful for IDE integration"

130+ $ progDesc "Export the GHCi configuration used by ob run, etc.; useful for IDE integration"

128 ]

131 ]

132+ where

133+ useRelativePathsFlag = switch (long "use-relative-paths" <> help "Use relative paths")

129

134

130packageNames :: Parser [String]

135packageNames :: Parser [String]

131packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

136packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

@@ -401,7 +406,8 @@ ob = \case

401 ObCommand_Internal icmd -> case icmd of

406 ObCommand_Internal icmd -> case icmd of

402 ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do

407 ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do

403 liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths

408 liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths

409+ ObInternal_ExportGhciConfig interpretPathsList useRelativePaths ->

404− ObInternal_ExportGhciConfig interpretPathsList -> liftIO . putStrLn . unlines =<< withInterpretPaths interpretPathsList exportGhciConfig

410+ liftIO . putStrLn . unlines =<< withInterpretPaths interpretPathsList (exportGhciConfig useRelativePaths)

405

411

406-- | A helper for the common case that the command you want to run needs the project root and a resolved

412-- | A helper for the common case that the command you want to run needs the project root and a resolved

407-- set of interpret paths.

413-- set of interpret paths.

lib/command/src/Obelisk/Command/Run.hs+12−9

@@ -167,7 +167,7 @@ run root interpretPaths = do

167 withGhciScript pkgs $ \dotGhciPath -> do

168 assets <- findProjectAssets root

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

170− ghciArgs <- getGhciSessionSettings pkgs root

170+ ghciArgs <- getGhciSessionSettings pkgs root True

171 freePort <- getFreePort

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

173 [ "Obelisk.Run.run"

@@ -180,21 +180,21 @@ run root interpretPaths = do

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

181runRepl root interpretPaths = do

182 pkgs <- getParsedLocalPkgs root interpretPaths

183− ghciArgs <- getGhciSessionSettings pkgs "."

183+ ghciArgs <- getGhciSessionSettings pkgs "." True

184 withGhciScript pkgs $ \dotGhciPath ->

185 runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)

186

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

188runWatch root interpretPaths = do

189 pkgs <- getParsedLocalPkgs root interpretPaths

190− ghciArgs <- getGhciSessionSettings pkgs root

190+ ghciArgs <- getGhciSessionSettings pkgs root True

191 withGhciScript pkgs $ \dotGhciPath ->

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

193

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

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

195−exportGhciConfig root interpretPaths = do

195+exportGhciConfig useRelativePaths root interpretPaths = do

196 pkgs <- getParsedLocalPkgs root interpretPaths

197− getGhciSessionSettings pkgs "."

197+ getGhciSessionSettings pkgs "." useRelativePaths

198

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

200nixShellForInterpretPaths isPure shell root interpretPaths cmd = do

@@ -427,8 +427,9 @@ getGhciSessionSettings

427 :: (MonadObelisk m, Foldable f)

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

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

430+ -> Bool -- ^ Use relative paths

430 -> m [String]

431 -> m [String]

431−getGhciSessionSettings (toList -> packageInfos) pathBase = do

432+getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do

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

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

433 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize

434 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize

434 -- all paths to 'pathBase'.

435 -- all paths to 'pathBase'.

@@ -438,13 +439,15 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do

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

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

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

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

440 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg

441 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg

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

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

442

443

443 pure

444 pure

444 $ baseGhciOptions

445 $ baseGhciOptions

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

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

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

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

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

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

449+ where

450+ relativeTo' = if useRelativePaths then relativeTo else const

448

451

449baseGhciOptions :: [String]

452baseGhciOptions :: [String]

450baseGhciOptions =

453baseGhciOptions =

@@ -537,4 +540,4 @@ relativeTo dir base

537 $ zipDefaultWith Nothing Nothing (,)

540 $ zipDefaultWith Nothing Nothing (,)

538 (map Just $ splitDirectories base)

541 (map Just $ splitDirectories base)

539 (map Just $ splitDirectories dir)

542 (map Just $ splitDirectories dir)

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

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