{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module HsInspect.Workarounds where

import Control.Monad
import Control.Monad.IO.Class
import Data.List (delete, intercalate, isSuffixOf)
import Data.Set (Set)
import qualified Data.Set as Set
import DriverPipeline (preprocess)
import DynFlags (parseDynamicFilePragma)
import FastString
import qualified GHC as GHC
import HeaderInfo (getOptions)
import HscTypes (HscEnv, Target(..), TargetId(..))
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import GHC.Hs.ImpExp (ImportDecl(..))
#else
import HsImpExp (ImportDecl(..))
#endif
import Lexer
import Outputable (showPpr)
import Parser (parseHeader)
import RdrName (GlobalRdrEnv)
import SrcLoc
import StringBuffer
import System.Directory (getModificationTime, removeFile)

#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)
import Data.Maybe (fromJust, fromMaybe)
import OccName (emptyOccEnv)
#else
import TcRnTypes (tcg_rdr_env)
#endif

-- applies CPP rules to the input file and extracts the pragmas,
-- a more portable alternative to GHC.hGetStringBuffer
mkCppState :: HscEnv -> FilePath -> IO (PState, [Located String])
mkCppState :: HscEnv -> FilePath -> IO (PState, [Located FilePath])
mkCppState HscEnv
sess FilePath
file = do
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
  Either ErrorMessages (DynFlags, FilePath)
pp <- HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess HscEnv
sess FilePath
file Maybe InputFileBuffer
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing
  let (DynFlags
dflags, FilePath
tmp) = case Either ErrorMessages (DynFlags, FilePath)
pp of
        Left ErrorMessages
_ -> FilePath -> (DynFlags, FilePath)
forall a. HasCallStack => FilePath -> a
error (FilePath -> (DynFlags, FilePath))
-> FilePath -> (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
"preprocessing failed " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
file
        Right (DynFlags, FilePath)
success -> (DynFlags, FilePath)
success
#else
  (dflags, tmp) <- preprocess sess (file, Nothing)
#endif
  InputFileBuffer
full <- FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
tmp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
".hscpp" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
tmp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
removeFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
tmp
  let pragmas :: [Located FilePath]
pragmas = DynFlags -> InputFileBuffer -> FilePath -> [Located FilePath]
getOptions DynFlags
dflags InputFileBuffer
full FilePath
file
      loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
file) Int
1 Int
1
  (DynFlags
dflags', [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags [Located FilePath]
pragmas
  (PState, [Located FilePath]) -> IO (PState, [Located FilePath])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PState, [Located FilePath]) -> IO (PState, [Located FilePath]))
-> (PState, [Located FilePath]) -> IO (PState, [Located FilePath])
forall a b. (a -> b) -> a -> b
$ (DynFlags -> InputFileBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags' InputFileBuffer
full RealSrcLoc
loc, [Located FilePath]
pragmas)

parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs)
parseHeader' :: FilePath -> m ([FilePath], HsModule GhcPs)
parseHeader' FilePath
file = do
  HscEnv
sess <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  (PState
pstate, [Located FilePath]
pragmas) <- IO (PState, [Located FilePath]) -> m (PState, [Located FilePath])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PState, [Located FilePath]) -> m (PState, [Located FilePath]))
-> IO (PState, [Located FilePath])
-> m (PState, [Located FilePath])
forall a b. (a -> b) -> a -> b
$ HscEnv -> FilePath -> IO (PState, [Located FilePath])
mkCppState HscEnv
sess FilePath
file
  case P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
parseHeader PState
pstate of
    POk PState
_ (L SrcSpan
_ HsModule GhcPs
hsmod) -> ([FilePath], HsModule GhcPs) -> m ([FilePath], HsModule GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located FilePath -> FilePath
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located FilePath -> FilePath) -> [Located FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located FilePath]
pragmas, HsModule GhcPs
hsmod)
    ParseResult (Located (HsModule GhcPs))
_ -> FilePath -> m ([FilePath], HsModule GhcPs)
forall a. HasCallStack => FilePath -> a
error (FilePath -> m ([FilePath], HsModule GhcPs))
-> FilePath -> m ([FilePath], HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ FilePath
"parseHeader failed for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file

importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target)
importsOnly :: Set ModuleName -> FilePath -> m (Maybe ModuleName, Target)
importsOnly Set ModuleName
homes FilePath
file = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  ([FilePath]
pragmas, HsModule GhcPs
hsmod) <- FilePath -> m ([FilePath], HsModule GhcPs)
forall (m :: * -> *).
GhcMonad m =>
FilePath -> m ([FilePath], HsModule GhcPs)
parseHeader' FilePath
file
  let allowed :: GenLocated l (ImportDecl pass) -> Bool
allowed (L l
_ (ImportDecl{Located ModuleName
ideclName :: forall pass. ImportDecl pass -> Located ModuleName
ideclName :: Located ModuleName
ideclName})) = ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
ideclName) Set ModuleName
homes
#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
      allowed (L l
_ (XImportDecl XXImportDecl pass
_)) = Bool
False
#endif
      modname :: Maybe ModuleName
modname = Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
GHC.hsmodName HsModule GhcPs
hsmod
      extra :: FilePath
extra =
        if Maybe ModuleName
modname Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ModuleName
forall a. Maybe a
Nothing Bool -> Bool -> Bool
|| Maybe ModuleName
modname Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ FilePath -> ModuleName
GHC.mkModuleName FilePath
"Main")
        then FilePath
"\nmain = return ()"
        else FilePath
""
      imps :: [GenLocated SrcSpan (ImportDecl GhcPs)]
imps = (GenLocated SrcSpan (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpan (ImportDecl GhcPs)]
-> [GenLocated SrcSpan (ImportDecl GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter GenLocated SrcSpan (ImportDecl GhcPs) -> Bool
forall l pass. GenLocated l (ImportDecl pass) -> Bool
allowed ([GenLocated SrcSpan (ImportDecl GhcPs)]
 -> [GenLocated SrcSpan (ImportDecl GhcPs)])
-> [GenLocated SrcSpan (ImportDecl GhcPs)]
-> [GenLocated SrcSpan (ImportDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [GenLocated SrcSpan (ImportDecl GhcPs)]
forall pass. HsModule pass -> [LImportDecl pass]
GHC.hsmodImports HsModule GhcPs
hsmod
      -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066
      --            cannot use CPP in combination with targetContents
      pragmas' :: [FilePath]
pragmas' = FilePath -> [FilePath] -> [FilePath]
forall a. Eq a => a -> [a] -> [a]
delete FilePath
"-XCPP" [FilePath]
pragmas
      contents :: FilePath
contents =
        FilePath
"{-# OPTIONS_GHC " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " [FilePath]
pragmas') FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" #-}\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
        DynFlags -> HsModule GhcPs -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
showPpr DynFlags
dflags (HsModule GhcPs
hsmod { hsmodExports :: Maybe (Located [LIE GhcPs])
GHC.hsmodExports = Maybe (Located [LIE GhcPs])
forall a. Maybe a
Nothing
                               , hsmodImports :: [GenLocated SrcSpan (ImportDecl GhcPs)]
GHC.hsmodImports = [GenLocated SrcSpan (ImportDecl GhcPs)]
imps }) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
        FilePath
extra
      trimmed :: InputFileBuffer
trimmed = FilePath -> InputFileBuffer
stringToStringBuffer FilePath
contents

  UTCTime
ts <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> m UTCTime) -> IO UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationTime FilePath
file
  -- since 0f9ec9d1ff can't use Phase
  (Maybe ModuleName, Target) -> m (Maybe ModuleName, Target)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe ModuleName, Target) -> m (Maybe ModuleName, Target))
-> (Maybe ModuleName, Target) -> m (Maybe ModuleName, Target)
forall a b. (a -> b) -> a -> b
$ (Maybe ModuleName
modname, TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
file Maybe Phase
forall a. Maybe a
Nothing) Bool
False ((InputFileBuffer, UTCTime) -> Maybe (InputFileBuffer, UTCTime)
forall a. a -> Maybe a
Just (InputFileBuffer
trimmed, UTCTime
ts)))

parseModuleName' :: GHC.GhcMonad m => FilePath -> m (Maybe GHC.ModuleName)
parseModuleName' :: FilePath -> m (Maybe ModuleName)
parseModuleName' FilePath
file = do
  ([FilePath]
_, HsModule GhcPs
hsmod) <- FilePath -> m ([FilePath], HsModule GhcPs)
forall (m :: * -> *).
GhcMonad m =>
FilePath -> m ([FilePath], HsModule GhcPs)
parseHeader' FilePath
file
  Maybe ModuleName -> m (Maybe ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ModuleName -> m (Maybe ModuleName))
-> Maybe ModuleName -> m (Maybe ModuleName)
forall a b. (a -> b) -> a -> b
$ Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
GHC.hsmodName HsModule GhcPs
hsmod

-- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541
minf_rdr_env' :: GHC.GhcMonad m => GHC.ModuleName -> m GlobalRdrEnv
minf_rdr_env' :: ModuleName -> m GlobalRdrEnv
minf_rdr_env' ModuleName
m = do
#if MIN_VERSION_GLASGOW_HASKELL(8,8,2,0)
  Module
mo <- ModuleName -> Maybe FastString -> m Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
m Maybe FastString
forall a. Maybe a
Nothing
  (Maybe ModuleInfo -> ModuleInfo
forall a. HasCallStack => Maybe a -> a
fromJust -> ModuleInfo
mi) <- Module -> m (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
mo
  GlobalRdrEnv -> m GlobalRdrEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobalRdrEnv -> m GlobalRdrEnv)
-> (Maybe GlobalRdrEnv -> GlobalRdrEnv)
-> Maybe GlobalRdrEnv
-> m GlobalRdrEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> Maybe GlobalRdrEnv -> GlobalRdrEnv
forall a. a -> Maybe a -> a
fromMaybe GlobalRdrEnv
forall a. OccEnv a
emptyOccEnv (Maybe GlobalRdrEnv -> m GlobalRdrEnv)
-> Maybe GlobalRdrEnv -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Maybe GlobalRdrEnv
GHC.modInfoRdrEnv ModuleInfo
mi
#else
  modSum <- GHC.getModSummary m
  pmod <- GHC.parseModule modSum
  tmod <- GHC.typecheckModule pmod
  let (tc_gbl_env, _) = GHC.tm_internals_ tmod
  pure $ tcg_rdr_env tc_gbl_env
#endif