@@ -14,7 +14,7 @@ module Obelisk.Command.Run where
14import Control.Arrow ((&&&))
14import Control.Arrow ((&&&))
15import Control.Exception (Exception, bracket)
15import Control.Exception (Exception, bracket)
16import Control.Lens (ifor, (.~), (&))
16import Control.Lens (ifor, (.~), (&))
17−import Control.Monad (filterM)
17+import Control.Monad (filterM, unless, void)
18import Control.Monad.Except (runExceptT, throwError)
18import Control.Monad.Except (runExceptT, throwError)
19import Control.Monad.IO.Class (liftIO)
19import Control.Monad.IO.Class (liftIO)
20import Control.Monad.Reader (MonadIO)
20import Control.Monad.Reader (MonadIO)
@@ -25,14 +25,12 @@ import Data.Default (def)
25import Data.Either (partitionEithers)
25import Data.Either (partitionEithers)
26import Data.Foldable (fold, for_, toList)
26import Data.Foldable (fold, for_, toList)
27import Data.Functor.Identity (runIdentity)
27import Data.Functor.Identity (runIdentity)
28−import Data.List (intercalate)
29import Data.List.NonEmpty (NonEmpty)
28import Data.List.NonEmpty (NonEmpty)
30import qualified Data.List.NonEmpty as NE
29import qualified Data.List.NonEmpty as NE
31import Data.Map (Map)
30import Data.Map (Map)
32import qualified Data.Map as Map
31import qualified Data.Map as Map
33import qualified Data.Map.Monoidal as MMap
32import qualified Data.Map.Monoidal as MMap
34−import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
33+import Data.Maybe
35−import Data.Ord (comparing)
36import Data.Set (Set)
34import Data.Set (Set)
37import qualified Data.Set as Set
35import qualified Data.Set as Set
38import Data.String.Here.Interpolated (i)
36import Data.String.Here.Interpolated (i)
@@ -46,17 +44,17 @@ import Distribution.Compiler (CompilerFlavor(..))
46import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
44import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
47import Distribution.Parsec.ParseResult (runParseResult)
45import Distribution.Parsec.ParseResult (runParseResult)
48import qualified Distribution.System as Dist
46import qualified Distribution.System as Dist
49−import Distribution.Types.BuildInfo (buildable, cppOptions, defaultExtensions, defaultLanguage, hsSourceDirs, options)
47+import Distribution.Types.BuildInfo
50−import Distribution.Types.CondTree (simplifyCondTree)
48+import Distribution.Types.CondTree
51−import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
49+import Distribution.Types.GenericPackageDescription
52−import Distribution.Types.Library (libBuildInfo)
50+import Distribution.Types.Library
53−import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
51+import Distribution.Utils.Generic
54import qualified Distribution.Parsec.Common as Dist
52import qualified Distribution.Parsec.Common as Dist
55import qualified Hpack.Config as Hpack
53import qualified Hpack.Config as Hpack
56import qualified Hpack.Render as Hpack
54import qualified Hpack.Render as Hpack
57import qualified Hpack.Yaml as Hpack
55import qualified Hpack.Yaml as Hpack
58−import Language.Haskell.Extension (Extension, Language)
56+import Language.Haskell.Extension
59−import qualified Network.Socket as Socket
57+import Network.Socket hiding (Debug)
60import System.Directory
58import System.Directory
61import System.Environment (getExecutablePath)
59import System.Environment (getExecutablePath)
62import System.FilePath
60import System.FilePath
@@ -66,18 +64,19 @@ import System.IO.Temp (withSystemTempDirectory)
66import Obelisk.App (MonadObelisk)
64import Obelisk.App (MonadObelisk)
67import Obelisk.CliApp (
65import Obelisk.CliApp (
68 Severity (..),
66 Severity (..),
72 readCreateProcessWithExitCode,
71 readCreateProcessWithExitCode,
73 readProcessAndLogStderr,
72 readProcessAndLogStderr,
76 setDelegateCtlc,
74 setDelegateCtlc,
77 withSpinner,
76 withSpinner,
79import Obelisk.Command.Nix
78import Obelisk.Command.Nix
80−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
79+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
81import Obelisk.Command.Thunk (attrCacheFileName)
80import Obelisk.Command.Thunk (attrCacheFileName)
82import Obelisk.Command.Utils (findExePath, ghcidExePath)
81import Obelisk.Command.Utils (findExePath, ghcidExePath)
@@ -94,11 +93,9 @@ data CabalPackageInfo = CabalPackageInfo
94 -- ^ List of globally set languages of the library component
93 -- ^ List of globally set languages of the library component
95 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
94 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
96 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
95 -- ^ 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)
101−-- | 'Bool' with a better name for its purpose.
98+-- | 'Bool' with a better name for it's purpose.
102data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
99data Interpret = Interpret_Interpret | Interpret_NoInterpret deriving (Eq, Ord, Show)
104textInterpret :: Interpret -> Text
101textInterpret :: Interpret -> Text
@@ -151,7 +148,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
148 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
149 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153 freePort <- getFreePort
150 freePort <- getFreePort
154− runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
151+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155 [ show freePort
152 [ show freePort
156 , T.unpack assets
153 , T.unpack assets
157 , profileBaseName
154 , profileBaseName
@@ -159,16 +156,17 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159 , "-po" <> profileBaseName
156 , "-po" <> profileBaseName
160 ] <> rtsFlags
157 ] <> rtsFlags
161 <> [ "-RTS" ]
158 <> [ "-RTS" ]
159+ void $ waitForProcess ph
163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
161run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
164run root interpretPaths = do
162run root interpretPaths = do
165 pkgs <- getParsedLocalPkgs root interpretPaths
163 pkgs <- getParsedLocalPkgs root interpretPaths
164+ withGhciScript pkgs $ \dotGhciPath -> do
166− assets <- findProjectAssets root
165+ assets <- findProjectAssets root
167− putLog Debug $ "Assets impurely loaded from: " <> assets
166+ putLog Debug $ "Assets impurely loaded from: " <> assets
168− ghciArgs <- getGhciSessionSettings pkgs root True
167+ ghciArgs <- getGhciSessionSettings pkgs root True
169− freePort <- getFreePort
168+ freePort <- getFreePort
170− withGhciScriptArgs pkgs $ \dotGhciArgs -> do
171− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
169+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
172 [ "Obelisk.Run.run"
170 [ "Obelisk.Run.run"
173 , show freePort
171 , show freePort
174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
172 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -180,15 +178,15 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
180runRepl root interpretPaths = do
178runRepl root interpretPaths = do
181 pkgs <- getParsedLocalPkgs root interpretPaths
179 pkgs <- getParsedLocalPkgs root interpretPaths
182 ghciArgs <- getGhciSessionSettings pkgs "." True
180 ghciArgs <- getGhciSessionSettings pkgs "." True
183− withGhciScriptArgs pkgs $ \dotGhciArgs ->
181+ withGhciScript pkgs $ \dotGhciPath ->
184− runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
182+ runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
184runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
187runWatch root interpretPaths = do
185runWatch root interpretPaths = do
188 pkgs <- getParsedLocalPkgs root interpretPaths
186 pkgs <- getParsedLocalPkgs root interpretPaths
189 ghciArgs <- getGhciSessionSettings pkgs root True
187 ghciArgs <- getGhciSessionSettings pkgs root True
190− withGhciScriptArgs pkgs $ \dotGhciArgs ->
188+ withGhciScript pkgs $ \dotGhciPath ->
191− runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
189+ runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
193exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
191exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
194exportGhciConfig useRelativePaths root interpretPaths = do
192exportGhciConfig useRelativePaths root interpretPaths = do
@@ -304,16 +302,15 @@ parseCabalPackage
304 -> m (Maybe CabalPackageInfo)
302 -> m (Maybe CabalPackageInfo)
305parseCabalPackage dir = parseCabalPackage' dir >>= \case
303parseCabalPackage dir = parseCabalPackage' dir >>= \case
306 Left err -> Nothing <$ putLog Error err
304 Left err -> Nothing <$ putLog Error err
307− Right (Just (warnings, pkgInfo)) -> do
305+ Right (warnings, pkgInfo) -> do
308 for_ warnings $ putLog Warning . T.pack . show
306 for_ warnings $ putLog Warning . T.pack . show
309 pure $ Just pkgInfo
307 pure $ Just pkgInfo
310− Right Nothing -> pure Nothing
312-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
309-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
313parseCabalPackage'
310parseCabalPackage'
314 :: (MonadIO m)
311 :: (MonadIO m)
315 => FilePath -- ^ Package directory
312 => FilePath -- ^ Package directory
316− -> m (Either T.Text (Maybe ([Dist.PWarning], CabalPackageInfo)))
313+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
317parseCabalPackage' pkg = runExceptT $ do
314parseCabalPackage' pkg = runExceptT $ do
318 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
315 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
319 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
316 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
@@ -341,7 +338,7 @@ parseCabalPackage' pkg = runExceptT $ do
341 case condLibrary <$> result of
338 case condLibrary <$> result of
342 Right (Just condLib) -> do
339 Right (Just condLib) -> do
343 let (_, lib) = simplifyCondTree evalConfVar condLib
340 let (_, lib) = simplifyCondTree evalConfVar condLib
344− pure $ Just $ (warnings,) $ CabalPackageInfo
341+ pure $ (warnings,) $ CabalPackageInfo
345 { _cabalPackageInfo_packageName = T.pack packageName
342 { _cabalPackageInfo_packageName = T.pack packageName
346 , _cabalPackageInfo_packageFile = packageFile
343 , _cabalPackageInfo_packageFile = packageFile
347 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
344 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
@@ -353,19 +350,18 @@ parseCabalPackage' pkg = runExceptT $ do
353 , _cabalPackageInfo_defaultLanguage =
350 , _cabalPackageInfo_defaultLanguage =
354 defaultLanguage $ libBuildInfo lib
351 defaultLanguage $ libBuildInfo lib
355 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
352 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
356− , _cabalPackageInfo_cppOptions = cppOptions $ libBuildInfo lib
358− Right Nothing -> pure Nothing
354+ Right Nothing -> throwError "Haskell package has no library component"
359 Left (_, errors) ->
355 Left (_, errors) ->
360 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
356 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
362parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
358parsePackagesOrFail :: (MonadObelisk m, Foldable f) => f FilePath -> m (NE.NonEmpty CabalPackageInfo)
363parsePackagesOrFail dirs' = do
359parsePackagesOrFail dirs' = do
364− packageInfos' <- fmap catMaybes $ for dirs $ \dir -> do
360+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
365 flip fmap (parseCabalPackage dir) $ \case
361 flip fmap (parseCabalPackage dir) $ \case
366 Just packageInfo
362 Just packageInfo
367− | _cabalPackageInfo_buildable packageInfo -> Just packageInfo
363+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
368− _ -> Nothing
364+ _ -> Left dir
370 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
366 -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.
371 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
367 let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))
@@ -387,6 +383,9 @@ parsePackagesOrFail dirs' = do
387 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
383 "No valid, buildable packages found" <> (if null dirs then "" else " in " <> intercalate ", " dirs)
388 Just xs -> pure xs
384 Just xs -> pure xs
386+ unless (null pkgDirErrs) $
387+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
390 pure packageInfos
389 pure packageInfos
392 dirs = toList dirs'
391 dirs = toList dirs'
@@ -394,29 +393,13 @@ parsePackagesOrFail dirs' = do
394packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
393packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
395packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
394packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
397−-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
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
403−withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
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
412-- | Create ghci configuration to load the given packages
396-- | Create ghci configuration to load the given packages
413withGhciScript
397withGhciScript
414 :: (MonadObelisk m, Foldable f)
398 :: (MonadObelisk m, Foldable f)
415− => [String] -- ^ Commands to prefix to file
416− -> f CabalPackageInfo -- ^ List of packages to load into ghci
399+ => f CabalPackageInfo -- ^ List of packages to load into ghci
417 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
400 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
419−withGhciScript preCommands (toList -> packageInfos) f =
402+withGhciScript (toList -> packageInfos) f =
420 withSystemTempDirectory "ob-ghci" $ \fp -> do
403 withSystemTempDirectory "ob-ghci" $ \fp -> do
421 let dotGhciPath = fp </> ".ghci"
404 let dotGhciPath = fp </> ".ghci"
422 liftIO $ writeFile dotGhciPath dotGhci
405 liftIO $ writeFile dotGhciPath dotGhci
@@ -428,8 +411,7 @@ withGhciScript preCommands (toList -> packageInfos) f =
428 , [ "Backend" | "backend" `Set.member` packageNames ]
411 , [ "Backend" | "backend" `Set.member` packageNames ]
429 , [ "Frontend" | "frontend" `Set.member` packageNames ]
412 , [ "Frontend" | "frontend" `Set.member` packageNames ]
431− dotGhci = unlines $
414+ dotGhci = unlines
433 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
415 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
434 , "import qualified Obelisk.Run"
416 , "import qualified Obelisk.Run"
435 , "import qualified Frontend"
417 , "import qualified Frontend"
@@ -482,7 +464,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
482 -- 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
483 -- 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.
484 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
466 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
485− Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
467+ Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
487-- | Run ghcid
469-- | Run ghcid
@@ -495,28 +477,32 @@ runGhcid
496runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
478runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
497 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
479 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
498− Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
480+ Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
500− opts = concat
482+ opts =
502− , ["--outputfile=ghcid-output.txt"]
484+ , "--outputfile=ghcid-output.txt"
503− , map (\x -> "--reload=" <> x) reloadFiles
485+ ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
504− , map (\x -> "--restart=" <> x) restartFiles
486+ <> map (\x -> "--restart='" <> x <> "'") restartFiles
505− , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
487+ <> testCmd
506− , ["--command=" <> unwords ("ghci" : ghciArgs)]
488+ <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
507− ]
489+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
508 adjustRoot x = if chdirToRoot then makeRelative root x else x
491 adjustRoot x = if chdirToRoot then makeRelative root x else x
509 reloadFiles = map adjustRoot [root </> "config"]
492 reloadFiles = map adjustRoot [root </> "config"]
510 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
493 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
495+mkGhciScriptArg :: FilePath -> [String]
496+mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
512−getFreePort :: MonadIO m => m Socket.PortNumber
498+getFreePort :: MonadIO m => m PortNumber
513−getFreePort = liftIO $ Socket.withSocketsDo $ do
499+getFreePort = liftIO $ withSocketsDo $ do
514− addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
500+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
515− bracket (open addr) Socket.close Socket.socketPort
501+ bracket (open addr) close socketPort
517 open addr = do
503 open addr = do
518− sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
504+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
519− Socket.bind sock (Socket.addrAddress addr)
505+ bind sock (addrAddress addr)
520 return sock
506 return sock