@@ -14,24 +14,25 @@ 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)
2121import Data.Bifoldable (bifoldr1)
2222import Data.Bifunctor (bimap)
23−import qualified Data.ByteString.UTF8 as BSU
2423import Data.Coerce (coerce)
2524import Data.Default (def)
2625import Data.Either (partitionEithers)
2726import Data.Foldable (fold, for_, toList)
2827import Data.Functor.Identity (runIdentity)
28+import Data.List (intercalate)
2929import Data.List.NonEmpty (NonEmpty)
3030import qualified Data.List.NonEmpty as NE
3131import Data.Map (Map)
3232import qualified Data.Map as Map
3333import qualified Data.Map.Monoidal as MMap
34−import Data.Maybe
34+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
35+import Data.Ord (comparing)
3536import Data.Set (Set)
3637import qualified Data.Set as Set
3738import Data.String.Here.Interpolated (i)
@@ -45,40 +46,38 @@ import Distribution.Compiler (CompilerFlavor(..))
4546import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4647import Distribution.Parsec.ParseResult (runParseResult)
4748import qualified Distribution.System as Dist
48−import Distribution.Types.BuildInfo
49−import Distribution.Types.CondTree
50−import Distribution.Types.GenericPackageDescription
51−import Distribution.Types.Library
52−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)
5354import qualified Distribution.Parsec.Common as Dist
5455import qualified Hpack.Config as Hpack
5556import qualified Hpack.Render as Hpack
5657import qualified Hpack.Yaml as Hpack
57−import Language.Haskell.Extension
58−import Network.Socket hiding (Debug)
58+import Language.Haskell.Extension (Extension, Language)
59+import qualified Network.Socket as Socket
5960import System.Directory
6061import System.Environment (getExecutablePath)
6162import System.FilePath
6263import qualified System.Info
6364import System.IO.Temp (withSystemTempDirectory)
64−import Text.ShellEscape (bash, bytes)
6565
6666import Obelisk.App (MonadObelisk)
6767import Obelisk.CliApp (
6868 Severity (..),
69− createProcess_,
7069 failWith,
7170 proc,
7271 putLog,
7372 readCreateProcessWithExitCode,
7473 readProcessAndLogStderr,
74+ runProcess_,
7575 setCwd,
7676 setDelegateCtlc,
77− waitForProcess,
7877 withSpinner,
7978 )
8079import Obelisk.Command.Nix
81−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
80+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
8281import Obelisk.Command.Thunk (attrCacheFileName)
8382import Obelisk.Command.Utils (findExePath, ghcidExePath)
8483
@@ -95,9 +94,11 @@ data CabalPackageInfo = CabalPackageInfo
9594 -- ^ List of globally set languages of the library component
9695 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9796 -- ^ 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)
9899 }
99100
100−-- | 'Bool' with a better name for it's purpose.
101+-- | 'Bool' with a better name for its purpose.
101102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
102103
103104textInterpret :: Interpret -> Text
@@ -150,7 +151,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
150151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
151152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
152153 freePort <- getFreePort
153− (_, _, _, 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") $
154155 [ show freePort
155156 , T.unpack assets
156157 , profileBaseName
@@ -158,17 +159,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
158159 , "-po" <> profileBaseName
159160 ] <> rtsFlags
160161 <> [ "-RTS" ]
161− void $ waitForProcess ph
162162
163163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164164run root interpretPaths = do
165165 pkgs <- getParsedLocalPkgs root interpretPaths
166− withGhciScript pkgs $ \dotGhciPath -> do
167− assets <- findProjectAssets root
168− putLog Debug $ "Assets impurely loaded from: " <> assets
169− ghciArgs <- getGhciSessionSettings pkgs root True
170− freePort <- getFreePort
171− 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
172172 [ "Obelisk.Run.run"
173173 , show freePort
174174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -180,15 +180,15 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180180runRepl root interpretPaths = do
181181 pkgs <- getParsedLocalPkgs root interpretPaths
182182 ghciArgs <- getGhciSessionSettings pkgs "." True
183− withGhciScript pkgs $ \dotGhciPath ->
184− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
185185
186186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187187runWatch root interpretPaths = do
188188 pkgs <- getParsedLocalPkgs root interpretPaths
189189 ghciArgs <- getGhciSessionSettings pkgs root True
190− withGhciScript pkgs $ \dotGhciPath ->
191− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
192192
193193exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194194exportGhciConfig useRelativePaths root interpretPaths = do
@@ -304,15 +304,16 @@ parseCabalPackage
304304 -> m (Maybe CabalPackageInfo)
305305parseCabalPackage dir = parseCabalPackage' dir >>= \case
306306 Left err -> Nothing <$ putLog Error err
307− Right (warnings, pkgInfo) -> do
307+ Right (Just (warnings, pkgInfo)) -> do
308308 for_ warnings $ putLog Warning . T.pack . show
309309 pure $ Just pkgInfo
310+ Right Nothing -> pure Nothing
310311
311312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
312313parseCabalPackage'
313314 :: (MonadIO m)
314315 => FilePath -- ^ Package directory
315− -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
316+ -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
316317parseCabalPackage' pkg = runExceptT $ do
317318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
318319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -340,7 +341,7 @@ parseCabalPackage' pkg = runExceptT $ do
340341 case condLibrary <$> result of
341342 Right (Just condLib) -> do
342343 let (_, lib) = simplifyCondTree evalConfVar condLib
343− pure $ (warnings,) $ CabalPackageInfo
344+ pure $ Just $ (warnings,) $ CabalPackageInfo
344345 { _cabalPackageInfo_packageName = T.pack packageName
345346 , _cabalPackageInfo_packageFile = packageFile
346347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -352,18 +353,19 @@ parseCabalPackage' pkg = runExceptT $ do
352353 , _cabalPackageInfo_defaultLanguage =
353354 defaultLanguage $ libBuildInfo lib
354355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356+ , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
355357 }
356− Right Nothing -> throwError "Haskell package has no library component"
358+ Right Nothing -> pure Nothing
357359 Left (_, errors) ->
358360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
359361
360362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
361363parsePackagesOrFail dirs' = do
362− (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
364+ packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
363365 flip fmap (parseCabalPackage dir) $ \case
364366 Just packageInfo
365− | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
366− _ -> Left dir
367+ | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368+ _ -> Nothing
367369
368370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
369371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -385,9 +387,6 @@ parsePackagesOrFail dirs' = do
385387 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
386388 Just xs -> pure xs
387389
388− unless (null pkgDirErrs) $
389− putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
390−
391390 pure packageInfos
392391 where
393392 dirs = toList dirs'
@@ -395,13 +394,29 @@ parsePackagesOrFail dirs' = do
395394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
396395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
397396
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+
398412-- | Create ghci configuration to load the given packages
399413withGhciScript
400414 :: (MonadObelisk m, Foldable f)
401− => 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
402417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
403418 -> m ()
404−withGhciScript (toList -> packageInfos) f =
419+withGhciScript preCommands (toList -> packageInfos) f =
405420 withSystemTempDirectory "ob-ghci" $ \fp -> do
406421 let dotGhciPath = fp </> ".ghci"
407422 liftIO $ writeFile dotGhciPath dotGhci
@@ -413,7 +428,8 @@ withGhciScript (toList -> packageInfos) f =
413428 , [ "Backend" | "backend" `Set.member` packageNames ]
414429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
415430 ]
416− dotGhci = unlines
431+ dotGhci = unlines $
432+ preCommands <>
417433 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
418434 , "import qualified Obelisk.Run"
419435 , "import qualified Frontend"
@@ -466,7 +482,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
466482 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
467483 -- ghc that is provided by the shell in the user's project.
468484 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
469− Just $ unwords $ fmap (BSU.toString . bytes . bash . BSU.fromString) $ "ghci" : ghciArgs
485+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
470486
471487-- | Run ghcid
472488runGhcid
@@ -479,7 +495,7 @@ runGhcid
479495 -> m ()
480496runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
481497 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
482− Just $ unwords $ fmap (BSU.toString . bytes . bash . BSU.fromString) $ ghcidExePath : opts
498+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
483499 where
484500 opts = concat
485501 [ ["-W"]
@@ -493,17 +509,14 @@ runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
493509 reloadFiles = map adjustRoot [root </> "config"]
494510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
495511
496−mkGhciScriptArg :: FilePath -> [String]
497−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
498−
499−getFreePort :: MonadIO m => m PortNumber
500−getFreePort = liftIO $ withSocketsDo $ do
501− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
502− 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
503516 where
504517 open addr = do
505− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
506− bind sock (addrAddress addr)
518+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519+ Socket.bind sock (Socket.addrAddress addr)
507520 return sock
508521
509522