@@ -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, unless)
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, 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
@@ -109,9 +110,6 @@ data PathTree a = PathTree_Node
109110 (Map FilePath (PathTree a)) -- Branches to deeper leaves
110111 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
111112
112−emptyPathTree :: PathTree a
113−emptyPathTree = PathTree_Node Nothing mempty
114−
115113-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116114drawPathTree :: (a -> Text) -> PathTree a -> Text
117115drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -151,7 +149,7 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
151149 liftIO $ createDirectoryIfMissing True $ takeDirectory $ root </> profileBaseName
152150 putLog Debug $ "Storing profiled data under base name of " <> T.pack (root </> profileBaseName)
153151 freePort <- getFreePort
154− (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
152+ runProcess_ $ setCwd (Just root) $ setDelegateCtlc True $ proc (outPath </> "bin" </> "ob-run") $
155153 [ show freePort
156154 , T.unpack assets
157155 , profileBaseName
@@ -159,17 +157,16 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
159157 , "-po" <> profileBaseName
160158 ] <> rtsFlags
161159 <> [ "-RTS" ]
162− void $ waitForProcess ph
163160
164161run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
165162run root interpretPaths = do
166163 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 True
171− freePort <- getFreePort
172− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs $ Just $ unwords
164+ assets <- findProjectAssets root
165+ putLog Debug $ "Assets impurely loaded from: " <> assets
166+ ghciArgs <- getGhciSessionSettings pkgs root True
167+ freePort <- getFreePort
168+ withGhciScriptArgs pkgs $ \dotGhciArgs -> do
169+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
173170 [ "Obelisk.Run.run"
174171 , show freePort
175172 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -181,15 +178,15 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
181178runRepl root interpretPaths = do
182179 pkgs <- getParsedLocalPkgs root interpretPaths
183180 ghciArgs <- getGhciSessionSettings pkgs "." True
184− withGhciScript pkgs $ \dotGhciPath ->
185− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
181+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
182+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
186183
187184runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
188185runWatch root interpretPaths = do
189186 pkgs <- getParsedLocalPkgs root interpretPaths
190187 ghciArgs <- getGhciSessionSettings pkgs root True
191− withGhciScript pkgs $ \dotGhciPath ->
192− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
188+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
189+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
193190
194191exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
195192exportGhciConfig useRelativePaths root interpretPaths = do
@@ -396,13 +393,29 @@ parsePackagesOrFail dirs' = do
396393packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
397394packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
398395
396+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
397+withGhciScriptArgs
398+ :: (MonadObelisk m, Foldable f)
399+ => f CabalPackageInfo -- ^ List of packages to load into ghci
400+ -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
401+ -> m ()
402+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
403+ where
404+ -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
405+ -- is passed to the ghci session.
406+ loadPreludeManually =
407+ [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
408+ , ":set -XImplicitPrelude" -- Turn the default setting on
409+ ]
410+
399411-- | Create ghci configuration to load the given packages
400412withGhciScript
401413 :: (MonadObelisk m, Foldable f)
402− => f CabalPackageInfo -- ^ List of packages to load into ghci
414+ => [String] -- ^ Commands to prefix to file
415+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
403416 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
404417 -> m ()
405−withGhciScript (toList -> packageInfos) f =
418+withGhciScript preCommands (toList -> packageInfos) f =
406419 withSystemTempDirectory "ob-ghci" $ \fp -> do
407420 let dotGhciPath = fp </> ".ghci"
408421 liftIO $ writeFile dotGhciPath dotGhci
@@ -414,7 +427,8 @@ withGhciScript (toList -> packageInfos) f =
414427 , [ "Backend" | "backend" `Set.member` packageNames ]
415428 , [ "Frontend" | "frontend" `Set.member` packageNames ]
416429 ]
417− dotGhci = unlines
430+ dotGhci = unlines $
431+ preCommands <>
418432 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
419433 , "import qualified Obelisk.Run"
420434 , "import qualified Frontend"
@@ -467,7 +481,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
467481 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
468482 -- ghc that is provided by the shell in the user's project.
469483 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
470− Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
484+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
471485
472486-- | Run ghcid
473487runGhcid
@@ -480,32 +494,28 @@ runGhcid
480494 -> m ()
481495runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
482496 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
483− Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
497+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
484498 where
485− opts =
486− [ "-W"
487− , "--outputfile=ghcid-output.txt"
488− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
489− <> map (\x -> "--restart='" <> x <> "'") restartFiles
490− <> testCmd
491− <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
492− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
493−
499+ opts = concat
500+ [ ["-W"]
501+ , ["--outputfile=ghcid-output.txt"]
502+ , map (\x -> "--reload=" <> x) reloadFiles
503+ , map (\x -> "--restart=" <> x) restartFiles
504+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
505+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
506+ ]
494507 adjustRoot x = if chdirToRoot then makeRelative root x else x
495508 reloadFiles = map adjustRoot [root </> "config"]
496509 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
497510
498−mkGhciScriptArg :: FilePath -> [String]
499−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
500−
501−getFreePort :: MonadIO m => m PortNumber
502−getFreePort = liftIO $ withSocketsDo $ do
503− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
504− bracket (open addr) close socketPort
511+getFreePort :: MonadIO m => m Socket.PortNumber
512+getFreePort = liftIO $ Socket.withSocketsDo $ do
513+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
514+ bracket (open addr) Socket.close Socket.socketPort
505515 where
506516 open addr = do
507− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
508− bind sock (addrAddress addr)
517+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
518+ Socket.bind sock (Socket.addrAddress addr)
509519 return sock
510520
511521