@@ -14,25 +14,24 @@ module Obelisk.Command.Run where
1414import Control.Arrow ((&&&))
1515import Control.Exception (Exception, bracket)
1616import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM)
17+import Control.Monad (filterM, unless, void)
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
2324import Data.Coerce (coerce)
2425import Data.Default (def)
2526import Data.Either (partitionEithers)
2627import Data.Foldable (fold, for_, toList)
2728import 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 (catMaybes, fromMaybe, mapMaybe)
35−import Data.Ord (comparing)
34+import Data.Maybe
3635import Data.Set (Set)
3736import qualified Data.Set as Set
3837import Data.String.Here.Interpolated (i)
@@ -46,38 +45,40 @@ import Distribution.Compiler (CompilerFlavor(..))
4645import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
4746import Distribution.Parsec.ParseResult (runParseResult)
4847import qualified Distribution.System as Dist
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)
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
5453import qualified Distribution.Parsec.Common as Dist
5554import qualified Hpack.Config as Hpack
5655import qualified Hpack.Render as Hpack
5756import qualified Hpack.Yaml as Hpack
58−import Language.Haskell.Extension (Extension, Language)
59−import qualified Network.Socket as Socket
57+import Language.Haskell.Extension
58+import Network.Socket hiding (Debug)
6059import System.Directory
6160import System.Environment (getExecutablePath)
6261import System.FilePath
6362import qualified System.Info
6463import System.IO.Temp (withSystemTempDirectory)
64+import Text.ShellEscape (Bash, bash)
6565
6666import Obelisk.App (MonadObelisk)
6767import Obelisk.CliApp (
6868 Severity (..),
69+ createProcess_,
6970 failWith,
7071 proc,
7172 putLog,
7273 readCreateProcessWithExitCode,
7374 readProcessAndLogStderr,
74− runProcess_,
7575 setCwd,
7676 setDelegateCtlc,
77+ waitForProcess,
7778 withSpinner,
7879 )
7980import Obelisk.Command.Nix
80−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
81+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
8182import Obelisk.Command.Thunk (attrCacheFileName)
8283import Obelisk.Command.Utils (findExePath, ghcidExePath)
8384
@@ -94,11 +95,9 @@ data CabalPackageInfo = CabalPackageInfo
9495 -- ^ List of globally set languages of the library component
9596 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
9697 -- ^ 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)
9998 }
10099
101−-- | 'Bool' with a better name for its purpose.
100+-- | 'Bool' with a better name for it's purpose.
102101data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
103102
104103textInterpret :: Interpret -> Text
@@ -112,6 +111,9 @@ data PathTree a = PathTree_Node
112111 (Map FilePath (PathTree a)) -- Branches to deeper leaves
113112 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
114113
114+emptyPathTree :: PathTree a
115+emptyPathTree = PathTree_Node Nothing mempty
116+
115117-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116118drawPathTree :: (a -> Text) -> PathTree a -> Text
117119drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -151,7 +153,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151153 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152154 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153155 freePort <- getFreePort
154− runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
156+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155157 [ show freePort
156158 , T.unpack assets
157159 , profileBaseName
@@ -159,16 +161,17 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159161 , "-po" <> profileBaseName
160162 ] <> rtsFlags
161163 <> [ "-RTS" ]
164+ void $ waitForProcess ph
162165
163166run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164167run root interpretPaths = do
165168 pkgs <- getParsedLocalPkgs root interpretPaths
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
169+ withGhciScript pkgs $ \dotGhciPath -> do
170+ assets <- findProjectAssets root
171+ putLog Debug $ "Assets impurely loaded from: " <> assets
172+ ghciArgs <- getGhciSessionSettings pkgs root True
173+ freePort <- getFreePort
174+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
172175 [ "Obelisk.Run.run"
173176 , show freePort
174177 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -180,22 +183,22 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180183runRepl root interpretPaths = do
181184 pkgs <- getParsedLocalPkgs root interpretPaths
182185 ghciArgs <- getGhciSessionSettings pkgs "." True
183− withGhciScriptArgs pkgs $ \dotGhciArgs ->
184− runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
186+ withGhciScript pkgs $ \dotGhciPath ->
187+ runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
185188
186189runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187190runWatch root interpretPaths = do
188191 pkgs <- getParsedLocalPkgs root interpretPaths
189192 ghciArgs <- getGhciSessionSettings pkgs root True
190− withGhciScriptArgs pkgs $ \dotGhciArgs ->
191− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
193+ withGhciScript pkgs $ \dotGhciPath ->
194+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
192195
193196exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194197exportGhciConfig useRelativePaths root interpretPaths = do
195198 pkgs <- getParsedLocalPkgs root interpretPaths
196199 getGhciSessionSettings pkgs "." useRelativePaths
197200
198−nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe String -> m ()
201+nixShellForInterpretPaths :: MonadObelisk m => Bool -> String -> FilePath -> PathTree Interpret -> Maybe [Bash] -> m ()
199202nixShellForInterpretPaths isPure shell root interpretPaths cmd = do
200203 pkgs <- getParsedLocalPkgs root interpretPaths
201204 nixShellWithoutPkgs root isPure False (packageInfoToNamePathMap pkgs) shell cmd
@@ -304,16 +307,15 @@ parseCabalPackage
304307 -> m (Maybe CabalPackageInfo)
305308parseCabalPackage dir = parseCabalPackage' dir >>= \case
306309 Left err -> Nothing <$ putLog Error err
307− Right (Just (warnings, pkgInfo)) -> do
310+ Right (warnings, pkgInfo) -> do
308311 for_ warnings $ putLog Warning . T.pack . show
309312 pure $ Just pkgInfo
310− Right Nothing -> pure Nothing
311313
312314-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313315parseCabalPackage'
314316 :: (MonadIO m)
315317 => FilePath -- ^ Package directory
316− -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
318+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
317319parseCabalPackage' pkg = runExceptT $ do
318320 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319321 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -341,7 +343,7 @@ parseCabalPackage' pkg = runExceptT $ do
341343 case condLibrary <$> result of
342344 Right (Just condLib) -> do
343345 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ Just $ (warnings,) $ CabalPackageInfo
346+ pure $ (warnings,) $ CabalPackageInfo
345347 { _cabalPackageInfo_packageName = T.pack packageName
346348 , _cabalPackageInfo_packageFile = packageFile
347349 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -353,19 +355,18 @@ parseCabalPackage' pkg = runExceptT $ do
353355 , _cabalPackageInfo_defaultLanguage =
354356 defaultLanguage $ libBuildInfo lib
355357 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356− , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
357358 }
358− Right Nothing -> pure Nothing
359+ Right Nothing -> throwError "Haskell package has no library component"
359360 Left (_, errors) ->
360361 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
361362
362363parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
363364parsePackagesOrFail dirs' = do
364− packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
365+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
365366 flip fmap (parseCabalPackage dir) $ \case
366367 Just packageInfo
367− | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
368− _ -> Nothing
368+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
369+ _ -> Left dir
369370
370371 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371372 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -387,6 +388,9 @@ parsePackagesOrFail dirs' = do
387388 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
388389 Just xs -> pure xs
389390
391+ unless (null pkgDirErrs) $
392+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
393+
390394 pure packageInfos
391395 where
392396 dirs = toList dirs'
@@ -394,29 +398,13 @@ parsePackagesOrFail dirs' = do
394398packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395399packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
396400
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−
412401-- | Create ghci configuration to load the given packages
413402withGhciScript
414403 :: (MonadObelisk m, Foldable f)
415− => [String] -- ^ Commands to prefix to file
416− -> f CabalPackageInfo -- ^ List of packages to load into ghci
404+ => f CabalPackageInfo -- ^ List of packages to load into ghci
417405 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
418406 -> m ()
419−withGhciScript preCommands (toList -> packageInfos) f =
407+withGhciScript (toList -> packageInfos) f =
420408 withSystemTempDirectory "ob-ghci" $ \fp -> do
421409 let dotGhciPath = fp </> ".ghci"
422410 liftIO $ writeFile dotGhciPath dotGhci
@@ -428,8 +416,7 @@ withGhciScript preCommands (toList -> packageInfos) f =
428416 , [ "Backend" | "backend" `Set.member` packageNames ]
429417 , [ "Frontend" | "frontend" `Set.member` packageNames ]
430418 ]
431− dotGhci = unlines $
432− preCommands <>
419+ dotGhci = unlines
433420 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434421 , "import qualified Obelisk.Run"
435422 , "import qualified Frontend"
@@ -482,7 +469,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
482469 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
483470 -- ghc that is provided by the shell in the user's project.
484471 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485− Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
472+ Just $ fmap (bash . BSU.fromString) $ "ghci" : ghciArgs
486473
487474-- | Run ghcid
488475runGhcid
@@ -495,7 +482,7 @@ runGhcid
495482 -> m ()
496483runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497484 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498− Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
485+ Just $ fmap (bash . BSU.fromString) $ ghcidExePath : opts
499486 where
500487 opts = concat
501488 [ ["-W"]
@@ -509,14 +496,17 @@ runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
509496 reloadFiles = map adjustRoot [root </> "config"]
510497 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
511498
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
499+mkGhciScriptArg :: FilePath -> [String]
500+mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
501+
502+getFreePort :: MonadIO m => m PortNumber
503+getFreePort = liftIO $ withSocketsDo $ do
504+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
505+ bracket (open addr) close socketPort
516506 where
517507 open addr = do
518− sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
519− Socket.bind sock (Socket.addrAddress addr)
508+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
509+ bind sock (addrAddress addr)
520510 return sock
521511
522512