{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}

module HsInspect.Runner (runGhcAndJamMasterShe, ghcflags_flags) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except (ExceptT(..))
import Data.List (find, isPrefixOf)
import qualified Data.List as L
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import DynFlags (parseDynamicFlagsCmdLine, updOptLevel)
import qualified EnumSet as EnumSet
import GHC (Ghc, GhcMonad, getSessionDynFlags)
import qualified GHC as GHC
import HsInspect.Context
import HsInspect.Util (homeSources)
import HsInspect.Workarounds (parseModuleName')
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Environment (setEnv)

-- expects the PWD to be the same as the .cabal file and the PATH to be what the
-- build tool sees.
runGhcAndJamMasterShe :: [String] -> Bool -> Ghc a -> IO a
runGhcAndJamMasterShe :: [String] -> Bool -> Ghc a -> IO a
runGhcAndJamMasterShe ([String] -> [String]
filterFlags -> [String]
flags) Bool
setTargets Ghc a
work =
  let libdir :: Maybe String
libdir = (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
"-B" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
flags
      flags' :: [String]
flags' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-B" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [String]
flags
   in Maybe String -> Ghc a -> IO a
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc Maybe String
libdir (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  (Int -> DynFlags -> DynFlags
updOptLevel Int
0 -> DynFlags
dflags', (Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc (Located String -> String) -> [Located String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) -> [String]
_ghcargs, [Warn]
_) <-
    IO (DynFlags, [Located String], [Warn])
-> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
 -> Ghc (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> Ghc (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags (String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (String -> Located String) -> [String] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
flags')
  Ghc [InstalledUnitId] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [InstalledUnitId] -> Ghc ())
-> Ghc [InstalledUnitId] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags'
         { hscTarget :: HscTarget
GHC.hscTarget = HscTarget
GHC.HscInterpreted -- HscNothing compiles home modules, dunno why
         , ghcLink :: GhcLink
GHC.ghcLink   = GhcLink
GHC.LinkInMemory   -- required by HscInterpreted
         , ghcMode :: GhcMode
GHC.ghcMode   = GhcMode
GHC.MkDepend       -- prefer .hi to .hs for dependencies
         , warningFlags :: EnumSet WarningFlag
GHC.warningFlags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
         , fatalWarningFlags :: EnumSet WarningFlag
GHC.fatalWarningFlags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty
         }

  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
setTargets (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    -- The caller may have provided a list of home modules, but we do not trust
    -- them because the ghcflags plugin does not keep the flags up to date for
    -- incremental compiles.
    let mkTarget :: ModuleName -> Target
mkTarget ModuleName
m = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> TargetId
GHC.TargetModule ModuleName
m) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
    [ModuleName]
homeModules <- Ghc [ModuleName]
forall (m :: * -> *). GhcMonad m => m [ModuleName]
inferHomeModules
    [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets ([Target] -> Ghc ()) -> [Target] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
mkTarget (ModuleName -> Target) -> [ModuleName] -> [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
homeModules

  Ghc a
work

-- gets the flags (and sets the environment) from the output of the ghcflags plugin
ghcflags_flags :: Maybe FilePath -> ExceptT String IO [String]
ghcflags_flags :: Maybe String -> ExceptT String IO [String]
ghcflags_flags Maybe String
mf = do
  String
from <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getCurrentDirectory String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mf
  Context{String
package_dir :: Context -> String
package_dir :: String
package_dir, [Text]
ghcflags :: Context -> [Text]
ghcflags :: [Text]
ghcflags, Text
ghcpath :: Context -> Text
ghcpath :: Text
ghcpath} <- String -> ExceptT String IO Context
findContext String
from
  IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
setCurrentDirectory String
package_dir
    String -> String -> IO ()
setEnv String
"PATH" (Text -> String
T.unpack Text
ghcpath)
  [String] -> ExceptT String IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> ExceptT String IO [String])
-> [String] -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ghcflags

inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName]
inferHomeModules :: m [ModuleName]
inferHomeModules = do
  [String]
files <- m [String]
forall (m :: * -> *). GhcMonad m => m [String]
homeSources
  [Maybe ModuleName]
mmns <- (String -> m (Maybe ModuleName))
-> [String] -> m [Maybe ModuleName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> m (Maybe ModuleName)
forall (m :: * -> *). GhcMonad m => String -> m (Maybe ModuleName)
parseModuleName' [String]
files
  let main' :: ModuleName
main' = String -> ModuleName
GHC.mkModuleName String
"Main"
  [ModuleName] -> m [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName] -> m [ModuleName])
-> ([ModuleName] -> [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
L.nub ([ModuleName] -> [ModuleName])
-> ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName
main' ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleName] -> [ModuleName]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleName]
mmns
  -- stack often has duplicates

-- removes the "+RTS ... -RTS" sections
filterFlags :: [String] -> [String]
filterFlags :: [String] -> [String]
filterFlags [String]
args = case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"+RTS" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) [String]
args of
  ([String]
front, []) -> [String]
front
  ([String]
front, String
_ : [String]
middle) -> case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String
"-RTS" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) [String]
middle of
    ([String]
_, []) -> [String]
front -- bad input?
    ([String]
_, String
_ : [String]
back) -> [String]
front [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
back