@@ -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
@@ -109,9 +111,6 @@ data PathTree a = PathTree_Node
109111 (Map FilePath (PathTree a)) -- Branches to deeper leaves
110112 deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
111113
112−emptyPathTree :: PathTree a
113−emptyPathTree = PathTree_Node Nothing mempty
114−
115114-- | 2D ASCII drawing of a 'PathTree'. Adapted from Data.Tree.draw.
116115drawPathTree :: (a -> Text) -> PathTree a -> Text
117116drawPathTree showA (PathTree_Node _ ts0) = T.intercalate "\n" $ goForest (Map.toList ts0)
@@ -164,12 +163,12 @@ profile profileBasePattern rtsFlags = withProjectRoot "." $ \root -> do
164163run :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
165164run root interpretPaths = do
166165 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
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
173172 [ "Obelisk.Run.run"
174173 , show freePort
175174 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
@@ -181,15 +180,15 @@ runRepl :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
181180runRepl root interpretPaths = do
182181 pkgs <- getParsedLocalPkgs root interpretPaths
183182 ghciArgs <- getGhciSessionSettings pkgs "." True
184− withGhciScript pkgs $ \dotGhciPath ->
185− runGhciRepl root pkgs (ghciArgs <> mkGhciScriptArg dotGhciPath)
183+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
184+ runGhciRepl root pkgs (ghciArgs <> dotGhciArgs)
186185
187186runWatch :: MonadObelisk m => FilePath -> PathTree Interpret -> m ()
188187runWatch root interpretPaths = do
189188 pkgs <- getParsedLocalPkgs root interpretPaths
190189 ghciArgs <- getGhciSessionSettings pkgs root True
191− withGhciScript pkgs $ \dotGhciPath ->
192− runGhcid root True (ghciArgs <> mkGhciScriptArg dotGhciPath) pkgs Nothing
190+ withGhciScriptArgs pkgs $ \dotGhciArgs ->
191+ runGhcid root True (ghciArgs <> dotGhciArgs) pkgs Nothing
193192
194193exportGhciConfig :: MonadObelisk m => Bool -> FilePath -> PathTree Interpret -> m [String]
195194exportGhciConfig useRelativePaths root interpretPaths = do
@@ -396,13 +395,29 @@ parsePackagesOrFail dirs' = do
396395packageInfoToNamePathMap :: Foldable f => f CabalPackageInfo -> Map Text FilePath
397396packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot) . toList
398397
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+
399413-- | Create ghci configuration to load the given packages
400414withGhciScript
401415 :: (MonadObelisk m, Foldable f)
402− => 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
403418 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
404419 -> m ()
405−withGhciScript (toList -> packageInfos) f =
420+withGhciScript preCommands (toList -> packageInfos) f =
406421 withSystemTempDirectory "ob-ghci" $ \fp -> do
407422 let dotGhciPath = fp </> ".ghci"
408423 liftIO $ writeFile dotGhciPath dotGhci
@@ -414,7 +429,8 @@ withGhciScript (toList -> packageInfos) f =
414429 , [ "Backend" | "backend" `Set.member` packageNames ]
415430 , [ "Frontend" | "frontend" `Set.member` packageNames ]
416431 ]
417− dotGhci = unlines
432+ dotGhci = unlines $
433+ preCommands <>
418434 [ if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
419435 , "import qualified Obelisk.Run"
420436 , "import qualified Frontend"
@@ -467,7 +483,7 @@ runGhciRepl root (toList -> packages) ghciArgs =
467483 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
468484 -- ghc that is provided by the shell in the user's project.
469485 nixShellWithoutPkgs root True False (packageInfoToNamePathMap packages) "ghc" $
470− Just $ unwords $ "ghci" : ghciArgs -- TODO: Shell escape
486+ Just $ unwords $ fmap bashEscape $ "ghci" : ghciArgs
471487
472488-- | Run ghcid
473489runGhcid
@@ -480,32 +496,28 @@ runGhcid
480496 -> m ()
481497runGhcid root chdirToRoot ghciArgs (toList -> packages) mcmd =
482498 nixShellWithoutPkgs root True chdirToRoot (packageInfoToNamePathMap packages) "ghc" $
483− Just $ unwords $ ghcidExePath : opts -- TODO: Shell escape
499+ Just $ unwords $ fmap bashEscape $ ghcidExePath : opts
484500 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−
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+ ]
494509 adjustRoot x = if chdirToRoot then makeRelative root x else x
495510 reloadFiles = map adjustRoot [root </> "config"]
496511 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
497512
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
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
505517 where
506518 open addr = do
507− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
508− bind sock (addrAddress addr)
519+ sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
520+ Socket.bind sock (Socket.addrAddress addr)
509521 return sock
510522
511523