Merge pull request #2457 from AndrewRademacher/refactoring-ghci-support

Adding support for rendering GHCi scripts targeting different GHCi like applications.

Author: mgsloan

src/Stack/Exec.hs

@@ -21,7 +21,7 @@ import           System.Process.Log
 import           Control.Exception.Lifted
 import           Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
 import           System.Exit
-import           System.Process.Run (callProcess, Cmd(..))
+import           System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..))
 #ifdef WINDOWS
 import           System.Process.Read (EnvOverride)
 #else
@@ -78,3 +78,12 @@ execSpawn menv cmd0 args = do
     liftIO $ case e of
         Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
         Right () -> exitSuccess
+
+execObserve :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)
+    => EnvOverride -> String -> [String] -> m String
+execObserve menv cmd0 args = do
+    e <- $withProcessTimeLog cmd0 args $
+        try (callProcessObserveStdout (Cmd Nothing cmd0 menv args))
+    case e of
+        Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec
+        Right s -> return s

src/Stack/Ghci.hs

@@ -14,6 +14,10 @@ module Stack.Ghci
     , GhciException(..)
     , ghciSetup
     , ghci
+
+    -- TODO: Address what should and should not be exported.
+    , renderScriptGhci
+    , renderScriptIntero
     ) where
 
 import           Control.Applicative
@@ -30,7 +34,6 @@ import           Data.Either
 import           Data.Function
 import           Data.List
 import           Data.List.Extra (nubOrd)
-import           Data.List.Split (splitOn)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import           Data.Maybe
@@ -42,7 +45,6 @@ import           Data.Traversable (forM)
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Typeable (Typeable)
-import           Distribution.ModuleName (ModuleName)
 import           Distribution.PackageDescription (updatePackageDescription)
 import           Distribution.Text (display)
 import           Network.HTTP.Client.Conduit
@@ -56,6 +58,7 @@ import           Stack.Build.Source
 import           Stack.Build.Target
 import           Stack.Constants
 import           Stack.Exec
+import           Stack.Ghci.Script
 import           Stack.Package
 import           Stack.Types.PackageIdentifier
 import           Stack.Types.PackageName
@@ -64,7 +67,6 @@ import           Stack.Types.Build
 import           Stack.Types.Package
 import           Stack.Types.Compiler
 import           Stack.Types.Internal
-import           System.FilePath (takeBaseName)
 import           Text.Read (readMaybe)
 
 #ifndef WINDOWS
@@ -142,25 +144,8 @@ ghci opts@GhciOpts{..} = do
         $logWarn
             ("The following GHC options are incompatible with GHCi and have not been passed to it: " <>
              T.unwords (map T.pack (nubOrd omittedOpts)))
-    allModules <- checkForDuplicateModules ghciNoLoadModules pkgs
+    mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs
     oiDir <- objectInterfaceDir bconfig
-    (modulesToLoad, mainFile) <- if ghciNoLoadModules then return ([], Nothing) else do
-        mmainFile <- figureOutMainFile bopts mainIsTargets targets pkgs
-        modulesToLoad <- case mmainFile of
-            Just mainFile -> do
-                let (_, mfDirs, mfName) = filePathPieces mainFile
-                    mainPathPieces = map toFilePath mfDirs ++ [takeBaseName (toFilePath mfName)]
-                liftM catMaybes $ forM allModules $ \mn -> do
-                    let matchesModule = splitOn "." mn `isSuffixOf` mainPathPieces
-                    if matchesModule
-                        then do
-                            $logWarn $ "Warning: Omitting load of module " <> T.pack mn <>
-                               ", because it matches the filepath of the Main target, " <>
-                               T.pack (toFilePath mainFile)
-                            return Nothing
-                        else return (Just mn)
-            Nothing -> return allModules
-        return (modulesToLoad, mmainFile)
     let odir =
             [ "-odir=" <> toFilePathNoTrailingSep oiDir
             , "-hidir=" <> toFilePathNoTrailingSep oiDir ]
@@ -176,20 +161,68 @@ ghci opts@GhciOpts{..} = do
                  -- include CWD.
                   "-i" :
                   odir <> pkgopts <> ghciArgs <> extras)
-    withSystemTempDir "ghci" $ \tmpDir -> do
-        let macrosFile = tmpDir </> $(mkRelFile "cabal_macros.h")
-        macrosOpts <- preprocessCabalMacros pkgs macrosFile
-        if ghciNoLoadModules
-            then execGhci macrosOpts
-            else do
-                let scriptPath = tmpDir </> $(mkRelFile "ghci-script")
-                    fp = toFilePath scriptPath
-                    loadModules = ":add " <> unwords (map quoteFileName modulesToLoad)
-                    addMainFile = maybe "" ((":add " <>) . quoteFileName . toFilePath) mainFile
-                    bringIntoScope = ":module + " <> unwords modulesToLoad
-                liftIO (writeFile fp (unlines [loadModules,addMainFile,bringIntoScope]))
-                setScriptPerms fp
-                execGhci (macrosOpts ++ ["-ghci-script=" <> fp])
+        interrogateExeForRenderFunction = do
+            menv <- liftIO $ configEnvOverride config defaultEnvSettings
+            output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"]
+            if "Intero" `isPrefixOf` output
+                then return renderScriptIntero
+                else return renderScriptGhci
+
+    withSystemTempDir "ghci" $ \tmpDirectory -> do
+      macrosOptions <- writeMacrosFile tmpDirectory pkgs
+      if ghciNoLoadModules
+          then execGhci macrosOptions
+          else do
+              checkForDuplicateModules pkgs
+              renderFn <- interrogateExeForRenderFunction
+              scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile)
+              execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath])
+
+writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String]
+writeMacrosFile tmpDirectory packages = do
+  macrosOptions <- preprocessCabalMacros packages macrosFile
+  return macrosOptions
+  where
+    macrosFile = tmpDirectory </> $(mkRelFile "cabal_macros.h")
+
+writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m (Path Abs File)
+writeGhciScript tmpDirectory script = do
+  liftIO $ scriptToFile scriptPath script
+  setScriptPerms scriptFilePath
+  return scriptPath
+  where
+    scriptPath = tmpDirectory </> $(mkRelFile "ghci-script")
+    scriptFilePath = toFilePath scriptPath
+
+findOwningPackageForMain :: [GhciPkgInfo] -> Path Abs File -> Maybe GhciPkgInfo
+findOwningPackageForMain pkgs mainFile =
+  find (\pkg -> toFilePath (ghciPkgDir pkg) `isPrefixOf` toFilePath mainFile) pkgs
+
+renderScriptGhci :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript
+renderScriptGhci pkgs mainFile =
+  let addPhase    = mconcat $ fmap renderPkg pkgs
+      mainPhase   = case mainFile of
+                      Just path -> cmdAddFile path
+                      Nothing   -> mempty
+      modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs)
+   in addPhase <> mainPhase <> modulePhase
+  where
+    renderPkg pkg = cmdAdd (ghciPkgModules pkg)
+
+renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript
+renderScriptIntero pkgs mainFile =
+  let addPhase    = mconcat $ fmap renderPkg pkgs
+      mainPhase   = case mainFile of
+                      Just path ->
+                        case findOwningPackageForMain pkgs path of
+                          Just mainPkg -> cmdCdGhc (ghciPkgDir mainPkg) <> cmdAddFile path
+                          Nothing      -> cmdAddFile path
+                      Nothing   -> mempty
+      modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs)
+   in addPhase <> mainPhase <> modulePhase
+  where
+    renderPkg pkg = cmdCdGhc (ghciPkgDir pkg)
+                 <> cmdAdd (ghciPkgModules pkg)
 
 -- | Figure out the main-is file to load based on the targets. Sometimes there
 -- is none, sometimes it's unambiguous, sometimes it's
@@ -503,15 +536,14 @@ borderedWarning f = do
     $logWarn ""
     return x
 
-checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => Bool -> [GhciPkgInfo] -> m [String]
-checkForDuplicateModules noLoadModules pkgs = do
+checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m ()
+checkForDuplicateModules pkgs = do
     unless (null duplicates) $ do
         borderedWarning $ do
             $logWarn "The following modules are present in multiple packages:"
             forM_ duplicates $ \(mn, pns) -> do
                 $logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")")
-        unless noLoadModules $ throwM LoadingDuplicateModules
-    return (map fst allModules)
+        throwM LoadingDuplicateModules
   where
     duplicates, allModules :: [(String, [PackageName])]
     duplicates = filter (not . null . tail . snd) allModules
@@ -584,13 +616,6 @@ setScriptPerms fp = do
         ]
 #endif
 
-filePathPieces :: Path Abs File -> (Path Abs Dir, [Path Rel Dir], Path Rel File)
-filePathPieces x0 = go (parent x0, [], filename x0)
-  where
-    go (x, dirs, fp)
-        | parent x == x = (x, dirs, fp)
-        | otherwise = (parent x, dirname x : dirs, fp)
-
 {- Copied from Stack.Ide, may be useful in the future
 
 -- | Get options and target files for the given package info.
@@ -632,10 +657,3 @@ targetsCmd target go@GlobalOpts{..} =
                (mapM (getPackageOptsAndTargetFiles pwd) pkgs)
        forM_ targets (liftIO . putStrLn)
 -}
-
--- | Make sure that a filename with spaces in it gets the proper quotes.
-quoteFileName :: String -> String
-quoteFileName x =
-    if any (==' ') x
-        then show x
-        else x

src/Stack/Ghci/Script.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Stack.Ghci.Script
+  ( GhciScript
+  , ModuleName
+
+  , cmdAdd
+  , cmdAddFile
+  , cmdCdGhc
+  , cmdModule
+
+  , scriptToLazyByteString
+  , scriptToBuilder
+  , scriptToFile
+  ) where
+
+import           Control.Exception
+import           Data.ByteString.Lazy (ByteString)
+import           Data.ByteString.Builder
+import           Data.Monoid
+import           Data.List
+import           Data.Set (Set)
+import qualified Data.Set as S
+import           Data.Text (Text)
+import           Data.Text.Encoding (encodeUtf8Builder)
+import           Path
+import           System.IO
+
+import           Distribution.ModuleName hiding (toFilePath)
+
+newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] }
+
+instance Monoid GhciScript where
+  mempty = GhciScript []
+  (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs)
+
+data GhciCommand
+  = Add (Set ModuleName)
+  | AddFile (Path Abs File)
+  | CdGhc (Path Abs Dir)
+  | Module (Set ModuleName)
+  deriving (Show)
+
+cmdAdd :: Set ModuleName -> GhciScript
+cmdAdd = GhciScript . (:[]) . Add
+
+cmdAddFile :: Path Abs File -> GhciScript
+cmdAddFile = GhciScript . (:[]) . AddFile
+
+cmdCdGhc :: Path Abs Dir -> GhciScript
+cmdCdGhc = GhciScript . (:[]) . CdGhc
+
+cmdModule :: Set ModuleName -> GhciScript
+cmdModule = GhciScript . (:[]) . Module
+
+scriptToLazyByteString :: GhciScript -> ByteString
+scriptToLazyByteString = toLazyByteString . scriptToBuilder
+
+scriptToBuilder :: GhciScript -> Builder
+scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script
+  where
+    script = reverse $ unGhciScript backwardScript
+
+scriptToFile :: Path Abs File -> GhciScript -> IO ()
+scriptToFile path script =
+  bracket (openFile filepath WriteMode) hClose
+    $ \hdl -> do hSetBuffering hdl (BlockBuffering Nothing)
+                 hSetBinaryMode hdl True
+                 hPutBuilder hdl (scriptToBuilder script)
+  where
+    filepath = toFilePath path
+
+-- Command conversion
+
+fromText :: Text -> Builder
+fromText = encodeUtf8Builder
+
+commandToBuilder :: GhciCommand -> Builder
+
+commandToBuilder (Add modules)
+  | S.null modules = mempty
+  | otherwise      =
+       fromText ":add "
+    <> (mconcat $ intersperse (fromText " ")
+        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)
+        $ S.toAscList modules)
+    <> fromText "\n"
+
+commandToBuilder (AddFile path) =
+  fromText ":add " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n"
+
+commandToBuilder (CdGhc path) =
+  fromText ":cd-ghc " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n"
+
+commandToBuilder (Module modules)
+  | S.null modules = fromText ":module +\n"
+  | otherwise      =
+       fromText ":module + "
+    <> (mconcat $ intersperse (fromText " ")
+        $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components)
+        $ S.toAscList modules)
+    <> fromText "\n"
+
+-- | Make sure that a filename with spaces in it gets the proper quotes.
+quoteFileName :: String -> String
+quoteFileName x =
+    if any (==' ') x
+        then show x
+        else x

src/System/Process/Run.hs

@@ -14,6 +14,7 @@ module System.Process.Run
     ,callProcess
     ,callProcess'
     ,callProcessInheritStderrStdout
+    ,callProcessObserveStdout
     ,createProcess'
     ,ProcessExitedUnsuccessfully
     ,Cmd(..)
@@ -112,6 +113,20 @@ callProcessInheritStderrStdout cmd = do
     let inheritOutput cp = cp { std_in = CreatePipe, std_out = Inherit, std_err = Inherit }
     callProcess' inheritOutput cmd
 
+callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String
+callProcessObserveStdout cmd = do
+    c <- liftM modCP (cmdToCreateProcess cmd)
+    $logCreateProcess c
+    liftIO $ do
+        (_, Just hStdout, _, p) <- System.Process.createProcess c
+        hSetBuffering hStdout NoBuffering
+        exit_code <- waitForProcess p
+        case exit_code of
+            ExitSuccess   -> hGetLine hStdout
+            ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
+  where
+    modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit }
+
 -- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'.
 -- Note that the 'Handle's provided by 'UseHandle' are not closed
 -- automatically.