@@ -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
@@ -76,7 +78,7 @@ import Obelisk.CliApp (
7678 withSpinner,
7779 )
7880import Obelisk.Command.Nix
79−import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets)
81+import Obelisk.Command.Project (nixShellWithoutPkgs, withProjectRoot, findProjectAssets, bashEscape)
8082import Obelisk.Command.Thunk (attrCacheFileName)
8183import Obelisk.Command.Utils (findExePath, ghcidExePath)
8284
@@ -161,12 +163,12 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
161163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
162164run root interpretPaths = do
163165 pkgs <- getParsedLocalPkgs root interpretPaths
164− withGhciScript pkgs $ \dotGhciPath -> do
165− assets <- findProjectAssets root
166− putLog Debug $ "Assets impurely loaded from: " <> assets
167− ghciArgs <- getGhciSessionSettings pkgs root True
168− freePort <- getFreePort
169− 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
170172 [ "Obelisk.Run.run"
171173 , show freePort
172174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -178,15 +180,15 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
178180runRepl root interpretPaths = do
179181 pkgs <- getParsedLocalPkgs root interpretPaths
180182 ghciArgs <- getGhciSessionSettings pkgs "." True
181− withGhciScript pkgs $ \dotGhciPath ->
182− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
183185
184186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
185187runWatch root interpretPaths = do
186188 pkgs <- getParsedLocalPkgs root interpretPaths
187189 ghciArgs <- getGhciSessionSettings pkgs root True
188− withGhciScript pkgs $ \dotGhciPath ->
189− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
190192
191193exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
192194exportGhciConfig useRelativePaths root interpretPaths = do
@@ -393,13 +395,29 @@ parsePackagesOrFail dirs' = do
393395packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
394396packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
395397
398+-- Like 'withGhciScript' but provides the precise ghci arguments to add to a ghci session
399+withGhciScriptArgs
400+ :: (MonadObelisk m, Foldable f)
401+ => f CabalPackageInfo -- ^ List of packages to load into ghci
402+ -> ([String] -> m ()) -- ^ Action to run with the extra ghci arguments
403+ -> m ()
404+withGhciScriptArgs packageInfos f = withGhciScript loadPreludeManually packageInfos $ \fp -> f ["-XNoImplicitPrelude", "-ghci-script", fp]
405+ where
406+ -- These lines must be first and allow the session to support a custom Prelude when @-XNoImplicitPrelude@
407+ -- is passed to the ghci session.
408+ loadPreludeManually =
409+ [ ":add Prelude" -- @:add@ is used because it's less noisy when there is no custom Prelude
410+ , ":set -XImplicitPrelude" -- Turn the default setting on
411+ ]
412+
396413-- | Create ghci configuration to load the given packages
397414withGhciScript
398415 :: (MonadObelisk m, Foldable f)
399− => f CabalPackageInfo -- ^ List of packages to load into ghci
416+ => [String] -- ^ Commands to prefix to file
417+ -> f CabalPackageInfo -- ^ List of packages to load into ghci
400418 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
401419 -> m ()
402−withGhciScript (toList -> packageInfos) f =
420+withGhciScript preCommands (toList -> packageInfos) f =
403421 withSystemTempDirectory "ob-ghci" $ \fp -> do
404422 let dotGhciPath = fp </> ".ghci"
405423 liftIO $ writeFile dotGhciPath dotGhci
@@ -411,7 +429,8 @@ withGhciScript (toList -> packageInfos) f =
411429 , [ "Backend" | "backend" `Set.member` packageNames ]
412430 , [ "Frontend" | "frontend" `Set.member` packageNames ]
413431 ]
414− dotGhci = unlines
432+ dotGhci = unlines $
433+ preCommands <>
415434 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
416435 , "import qualified Obelisk.Run"
417436 , "import qualified Frontend"
@@ -464,7 +483,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
464483 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
465484 -- ghc that is provided by the shell in the user's project.
466485 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
467− Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
486+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
468487
469488-- | Run ghcid
470489runGhcid
@@ -477,32 +496,28 @@ runGhcid
477496 -> m ()
478497runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
479498 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
480− Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
499+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
481500 where
482− opts =
483− [ "-W"
484− , "--outputfile=ghcid-output.txt"
485− ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
486− <> map (\x -> "--restart='" <> x <> "'") restartFiles
487− <> testCmd
488− <> ["--command='" <> unwords ("ghci" : ghciArgs) <> "'"] -- TODO: Shell escape
489− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
490−
501+ opts = concat
502+ [ ["-W"]
503+ , ["--outputfile=ghcid-output.txt"]
504+ , map (\x -> "--reload=" <> x) reloadFiles
505+ , map (\x -> "--restart=" <> x) restartFiles
506+ , maybe [] (\cmd -> ["--test=" <> cmd]) mcmd
507+ , ["--command=" <> unwords ("ghci" : ghciArgs)]
508+ ]
491509 adjustRoot x = if chdirToRoot then makeRelative root x else x
492510 reloadFiles = map adjustRoot [root </> "config"]
493511 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
494512
495−mkGhciScriptArg :: FilePath -> [String]
496−mkGhciScriptArg dotGhci = ["-ghci-script", dotGhci]
497−
498−getFreePort :: MonadIO m => m PortNumber
499−getFreePort = liftIO $ withSocketsDo $ do
500− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
501− bracket (open addr) close socketPort
513+getFreePort :: MonadIO m => m Socket.PortNumber
514+getFreePort = liftIO $ Socket.withSocketsDo $ do
515+ addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
516+ bracket (open addr) Socket.close Socket.socketPort
502517 where
503518 open addr = do
504− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
505− bind sock (addrAddress addr)
519+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
520+ Socket.bind sock (Socket.addrAddress addr)
506521 return sock
507522
508523