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