@@ -14,7 +14,7 @@ module Obelisk.Command.Run where
1414import Control.Arrow ((&&&))
1515import Control.Exception (Exception, bracket)
1616import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM, unless, void)
17+import Control.Monad (filterM)
1818import Control.Monad.Except (runExceptT, throwError)
1919import Control.Monad.IO.Class (liftIO)
2020import Control.Monad.Reader (MonadIO)
@@ -25,12 +25,14 @@ import Data.Default (def)
2525import Data.Either (partitionEithers)
2626import Data.Foldable (fold, for_, toList)
2727import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
2829import Data.List.NonEmpty (NonEmpty)
2930import qualified Data.List.NonEmpty as NE
3031import Data.Map (Map)
3132import qualified Data.Map as Map
3233import qualified Data.Map.Monoidal as MMap
33−import Data.Maybe
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
3436import Data.Set (Set)
3537import qualified Data.Set as Set
3638import Data.String.Here.Interpolated (i)
@@ -44,17 +46,17 @@ import Distribution.Compiler (CompilerFlavor(..))
4446import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4547import Distribution.Parsec.ParseResult (runParseResult)
4648import qualified Distribution.System as Dist
47−import Distribution.Types.BuildInfo
48−import Distribution.Types.CondTree
49−import Distribution.Types.GenericPackageDescription
50−import Distribution.Types.Library
51−import Distribution.Utils.Generic
49+import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
50+import Distribution.Types.CondTree (simplifyCondTree)
51+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
52+import Distribution.Types.Library (libBuildInfo)
53+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
5254import qualified Distribution.Parsec.Common as Dist
5355import qualified Hpack.Config as Hpack
5456import qualified Hpack.Render as Hpack
5557import qualified Hpack.Yaml as Hpack
56−import Language.Haskell.Extension
57−import Network.Socket hiding (Debug)
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
5860import System.Directory
5961import System.Environment (getExecutablePath)
6062import System.FilePath
@@ -64,19 +66,18 @@ import System.IO.Temp (withSystemTempDirectory)
6466import Obelisk.App (MonadObelisk)
6567import Obelisk.CliApp (
6668 Severity (..),
67− createProcess_,
6869 failWith,
6970 proc,
7071 putLog,
7172 readCreateProcessWithExitCode,
7273 readProcessAndLogStderr,
74+ runProcess_,
7375 setCwd,
7476 setDelegateCtlc,
75− waitForProcess,
7677 withSpinner,
7778 )
7879import Obelisk.Command.Nix
79−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
8081import Obelisk.Command.Thunk (attrCacheFileName)
8182import Obelisk.Command.Utils (findExePath, ghcidExePath)
8283
@@ -93,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
9394 -- ^ List of globally set languages of the library component
9495 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9596 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
97+ , _cabalPackageInfo_cppOptions :: [String]
98+ -- ^ List of CPP (C Preprocessor) options (e.g. the "cpp-options" field of the cabal file)
9699 }
97100
98−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
99102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
100103
101104textInterpret :: Interpret -> Text
@@ -109,9 +112,6 @@ data PathTree a = PathTree_Node
109112 (Map FilePath (PathTree a)) -- Branches to deeper leaves
110113 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
111114
112−emptyPathTree :: PathTree a
113−emptyPathTree = PathTree_Node Nothing mempty
114−
115115-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116116drawPathTree :: (a -> Text) -> PathTree a -> Text
117117drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -151,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153153 freePort <- getFreePort
154− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
154+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155155 [ show freePort
156156 , T.unpack assets
157157 , profileBaseName
@@ -159,17 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159159 , "-po" <> profileBaseName
160160 ] <> rtsFlags
161161 <> [ "-RTS" ]
162− void $ waitForProcess ph
163162
164163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
165164run root interpretPaths = do
166165 pkgs <- getParsedLocalPkgs root interpretPaths
167− withGhciScript pkgs $ \dotGhciPath -> do
168− assets <- findProjectAssets root
169− putLog Debug $ "Assets impurely loaded from: " <> assets
170− ghciArgs <- getGhciSessionSettings pkgs root
171− freePort <- getFreePort
172− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
166+ assets <- findProjectAssets root
167+ putLog Debug $ "Assets impurely loaded from: " <> assets
168+ ghciArgs <- getGhciSessionSettings pkgs root True
169+ freePort <- getFreePort
170+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
171+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
173172 [ "Obelisk.Run.run"
174173 , show freePort
175174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -180,21 +179,21 @@ run root interpretPaths = do
180179runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
181180runRepl root interpretPaths = do
182181 pkgs <- getParsedLocalPkgs root interpretPaths
183− ghciArgs <- getGhciSessionSettings pkgs "."
184− withGhciScript pkgs $ \dotGhciPath ->
185− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
182+ ghciArgs <- getGhciSessionSettings pkgs "." True
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
186185
187186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
188187runWatch root interpretPaths = do
189188 pkgs <- getParsedLocalPkgs root interpretPaths
190− ghciArgs <- getGhciSessionSettings pkgs root
191− withGhciScript pkgs $ \dotGhciPath ->
192− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
189+ ghciArgs <- getGhciSessionSettings pkgs root True
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
193192
194−exportGhciConfig :: MonadObelisk m => FilePath -> PathTree Interpret -> m [String]
195−exportGhciConfig root interpretPaths = do
193+exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194+exportGhciConfig useRelativePaths root interpretPaths = do
196195 pkgs <- getParsedLocalPkgs root interpretPaths
197− getGhciSessionSettings pkgs "."
196+ getGhciSessionSettings pkgs "." useRelativePaths
198197
199198nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
200199nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
@@ -305,15 +304,16 @@ parseCabalPackage
305304 -> m (Maybe CabalPackageInfo)
306305parseCabalPackage dir = parseCabalPackage' dir >>= \case
307306 Left err -> Nothing <$ putLog Error err
308− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
309308 for_ warnings $ putLog Warning . T.pack . show
310309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
311311
312312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313313parseCabalPackage'
314314 :: (MonadIO m)
315315 => FilePath -- ^ Package directory
316− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
317317parseCabalPackage' pkg = runExceptT $ do
318318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -341,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
341341 case condLibrary <$> result of
342342 Right (Just condLib) -> do
343343 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
345345 { _cabalPackageInfo_packageName = T.pack packageName
346346 , _cabalPackageInfo_packageFile = packageFile
347347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -353,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
353353 , _cabalPackageInfo_defaultLanguage =
354354 defaultLanguage $ libBuildInfo lib
355355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
356357 }
357− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
358359 Left (_, errors) ->
359360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
360361
361362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
362363parsePackagesOrFail dirs' = do
363− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
364365 flip fmap (parseCabalPackage dir) $ \case
365366 Just packageInfo
366− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
367− _ -> Left dir
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
368369
369370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
370371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -386,9 +387,6 @@ parsePackagesOrFail dirs' = do
386387 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
387388 Just xs -> pure xs
388389
389− unless (null pkgDirErrs) $
390− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
391−
392390 pure packageInfos
393391 where
394392 dirs = toList dirs'
@@ -396,13 +394,29 @@ parsePackagesOrFail dirs' = do
396394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
397395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
398396
397+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
398+withGhciScriptArgs
399+ :: (MonadObelisk m, Foldable f)
400+ => f CabalPackageInfo -- ^ List of packages to load into ghci
401+ -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
402+ -> m ()
403+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
404+ where
405+ -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
406+ -- is passed to the ghci session.
407+ loadPreludeManually =
408+ [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
409+ , ":set -XImplicitPrelude" -- Turn the default setting on
410+ ]
411+
399412-- | Create ghci configuration to load the given packages
400413withGhciScript
401414 :: (MonadObelisk m, Foldable f)
402− => f CabalPackageInfo -- ^ List of packages to load into ghci
415+ => [String] -- ^ Commands to prefix to file
416+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
403417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
404418 -> m ()
405−withGhciScript (toList -> packageInfos) f =
419+withGhciScript preCommands (toList -> packageInfos) f =
406420 withSystemTempDirectory "ob-ghci" $ \fp -> do
407421 let dotGhciPath = fp </> ".ghci"
408422 liftIO $ writeFile dotGhciPath dotGhci
@@ -414,7 +428,8 @@ withGhciScript (toList -> packageInfos) f =
414428 , [ "Backend" | "backend" `Set.member` packageNames ]
415429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
416430 ]
417− dotGhci = unlines
431+ dotGhci = unlines $
432+ preCommands <>
418433 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
419434 , "import qualified Obelisk.Run"
420435 , "import qualified Frontend"
@@ -427,8 +442,9 @@ getGhciSessionSettings
427442 :: (MonadObelisk m, Foldable f)
428443 => f CabalPackageInfo -- ^ List of packages to load into ghci
429444 -> FilePath -- ^ All paths will be relative to this path
445+ -> Bool -- ^ Use relative paths
430446 -> m [String]
431−getGhciSessionSettings (toList -> packageInfos) pathBase = do
447+getGhciSessionSettings (toList -> packageInfos) pathBase useRelativePaths = do
432448 -- N.B. ghci settings do NOT support escaping in any way. To minimize the likelihood that
433449 -- paths-with-spaces ruin our day, we first canonicalize everything, and then relativize
434450 -- all paths to 'pathBase'.
@@ -438,13 +454,15 @@ getGhciSessionSettings (toList -> packageInfos) pathBase = do
438454 (pkgFiles, pkgSrcPaths :: [NonEmpty FilePath]) <- fmap unzip $ liftIO $ for packageInfos $ \pkg -> do
439455 canonicalSrcDirs <- traverse canonicalizePath $ (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
440456 canonicalPkgFile <- canonicalizePath $ _cabalPackageInfo_packageFile pkg
441− pure (canonicalPkgFile `relativeTo` canonicalPathBase, (`relativeTo` canonicalPathBase) <$> canonicalSrcDirs)
457+ pure (canonicalPkgFile `relativeTo'` canonicalPathBase, (`relativeTo'` canonicalPathBase) <$> canonicalSrcDirs)
442458
443459 pure
444460 $ baseGhciOptions
445461 <> ["-F", "-pgmF", selfExe, "-optF", preprocessorIdentifier]
446462 <> concatMap (\p -> ["-optF", p]) pkgFiles
447463 <> [ "-i" <> intercalate ":" (concatMap toList pkgSrcPaths) ]
464+ where
465+ relativeTo' = if useRelativePaths then relativeTo else const
448466
449467baseGhciOptions :: [String]
450468baseGhciOptions =
@@ -464,7 +482,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
464482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
465483 -- ghc that is provided by the shell in the user's project.
466484 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
467− Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
468486
469487-- | Run ghcid
470488runGhcid
@@ -477,32 +495,28 @@ runGhcid
477495 -> m ()
478496runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
479497 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
480− Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
481499 where
482− opts =
483− [ "-W"
484− , "--outputfile=ghcid-output.txt"
485− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
486− <> map (\x -> "--restart='" <> x <> "'") restartFiles
487− <> testCmd
488− <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
489− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
490−
500+ opts = concat
501+ [ ["-W"]
502+ , ["--outputfile=ghcid-output.txt"]
503+ , map (\x -> "--reload=" <> x) reloadFiles
504+ , map (\x -> "--restart=" <> x) restartFiles
505+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
506+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
507+ ]
491508 adjustRoot x = if chdirToRoot then makeRelative root x else x
492509 reloadFiles = map adjustRoot [root </> "config"]
493510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
494511
495−mkGhciScriptArg :: FilePath -> [String]
496−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
497−
498−getFreePort :: MonadIO m => m PortNumber
499−getFreePort = liftIO $ withSocketsDo $ do
500− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
501− bracket (open addr) close socketPort
512+getFreePort :: MonadIO m => m Socket.PortNumber
513+getFreePort = liftIO $ Socket.withSocketsDo $ do
514+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
515+ bracket (open addr) Socket.close Socket.socketPort
502516 where
503517 open addr = do
504− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
505− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
506520 return sock
507521
508522
@@ -537,4 +551,4 @@ relativeTo dir base
537551 $ zipDefaultWith Nothing Nothing (,)
538552 (map Just $ splitDirectories base)
539553 (map Just $ splitDirectories dir)
540− where collapse = foldr (</>) ""
554+ where collapse = foldr (</>) ""