ghc-mod/core/GhcMod/Gap.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}

module GhcMod.Gap (
    GhcMod.Gap.ClsInst
  , mkTarget
  , withStyle
  , GmLogAction
  , setLogAction
  , getSrcSpan
  , getSrcFile
  , withInteractiveContext
  , ghcCmdOptions
  , toStringBuffer
  , showSeverityCaption
  , setCabalPkg
  , setHideAllPackages
  , setDeferTypeErrors
  , setDeferTypedHoles
  , setWarnTypedHoles
  , setDumpSplices
  , setNoMaxRelevantBindings
  , isDumpSplices
  , filterOutChildren
  , infoThing
  , pprInfo
  , HasType(..)
  , errorMsgSpan
  , setErrorMsgSpan
  , typeForUser
  , nameForUser
  , occNameForUser
  , deSugar
  , showDocWith
  , renderGm
  , GapThing(..)
  , fromTyThing
  , fileModSummary
  , WarnFlags
  , emptyWarnFlags
  , GLMatch
  , GLMatchI
  , getClass
  , occName
  , listVisibleModuleNames
  , listVisibleModules
  , lookupModulePackageInAllPackages
  , GhcMod.Gap.isSynTyCon
  , parseModuleHeader
  , mkErrStyle'
  , everythingStagedWithContext
  , withCleanupSession
  ) where

import Control.Applicative hiding (empty)
import Control.Monad (filterM)
import CoreSyn (CoreExpr)
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import Data.Time.Clock (UTCTime)
import Data.Traversable hiding (mapM)
import DataCon (dataConUserType)
import Desugar (deSugarExpr)
import DynFlags
import ErrUtils
import Exception
import FastString
import GhcMonad
import HscTypes
import NameSet
import OccName
import Outputable
import PprTyThing
import StringBuffer
import TcType
import Var (varType)
import System.Directory
import SysTools
#if __GLASGOW_HASKELL__ >= 800
import GHCi (stopIServ)
#endif

import qualified Name
import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB

#if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon)
#endif

#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
import PatSyn
#else
import TcRnTypes
#endif

-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0
-- It IS defined from 7.10.1 and up though.
-- So we can only test for 7.10.1.0 and up with it.
#if __GLASGOW_HASKELL__ < 710
#ifndef MIN_VERSION_GLASGOW_HASKELL
#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE
#endif
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
import GHC hiding (ClsInst, withCleanupSession)
import qualified GHC (withCleanupSession)
#elif __GLASGOW_HASKELL__ >= 706
import GHC hiding (ClsInst)
#else
import GHC hiding (Instance)
import Control.Arrow hiding ((<+>))
import Data.Convertible
import RdrName (rdrNameOcc)
#endif

#if __GLASGOW_HASKELL__ < 710
import UniqFM (eltsUFM)
import Module
#endif

#if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
#endif

#if __GLASGOW_HASKELL__ < 706
import Control.DeepSeq (NFData(rnf))
import Data.ByteString.Lazy.Internal (ByteString(..))
#endif

import Bag
import Lexer as L
import Parser
import SrcLoc
import Packages
import Data.Generics (GenericQ, extQ, gmapQ)
import GHC.SYB.Utils (Stage(..))

import GhcMod.Types (Expression(..))
import Prelude

----------------------------------------------------------------
----------------------------------------------------------------
--
#if __GLASGOW_HASKELL__ >= 706
type ClsInst = InstEnv.ClsInst
#else
type ClsInst = InstEnv.Instance
#endif

mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target
#if __GLASGOW_HASKELL__ >= 706
mkTarget = Target
#else
mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert
#endif

----------------------------------------------------------------
----------------------------------------------------------------

withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc
#if __GLASGOW_HASKELL__ >= 706
withStyle = withPprStyleDoc
#else
withStyle _ = withPprStyleDoc
#endif

#if __GLASGOW_HASKELL__ >= 800
-- flip LogAction
type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
#elif __GLASGOW_HASKELL__ >= 706
type GmLogAction = forall a. a -> LogAction
#else
type GmLogAction = forall a. a -> DynFlags -> LogAction
#endif

--  DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()

setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f =
#if __GLASGOW_HASKELL__ >= 800
    df { log_action = flip f }
#elif __GLASGOW_HASKELL__ >= 706
    df { log_action = f (error "setLogAction") }
#else
    df { log_action = f (error "setLogAction") df }
#endif

showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
showDocWith dflags mode = Pretty.renderStyle mstyle where
    mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }
#elif __GLASGOW_HASKELL__ >= 708
-- Pretty.showDocWith disappeard.
-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc
showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
#else
showDocWith _ = Pretty.showDocWith
#endif

renderGm :: Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
#else
renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
#endif
 where
   string_txt :: Pretty.TextDetails -> String -> String
   string_txt (Pretty.Chr c)   s  = c:s
   string_txt (Pretty.Str s1)  s2 = s1 ++ s2
   string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
   string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
#if __GLASGOW_HASKELL__ >= 708
   string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2
#endif


----------------------------------------------------------------
----------------------------------------------------------------

getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
#if __GLASGOW_HASKELL__ >= 702
getSrcSpan (RealSrcSpan spn)
#else
getSrcSpan spn | isGoodSrcSpan spn
#endif
             = Just (srcSpanStartLine spn
                   , srcSpanStartCol spn
                   , srcSpanEndLine spn
                   , srcSpanEndCol spn)
getSrcSpan _ = Nothing

getSrcFile :: SrcSpan -> Maybe String
#if __GLASGOW_HASKELL__ >= 702
getSrcFile (RealSrcSpan spn)       = Just . unpackFS . srcSpanFile $ spn
#else
getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn
#endif
getSrcFile _ = Nothing

----------------------------------------------------------------

toStringBuffer :: GhcMonad m => [String] -> m StringBuffer
#if __GLASGOW_HASKELL__ >= 702
toStringBuffer = return . stringToStringBuffer . unlines
#else
toStringBuffer = liftIO . stringToStringBuffer . unlines
#endif

----------------------------------------------------------------

ghcCmdOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710
-- this also includes -X options and all sorts of other things so the
ghcCmdOptions = flagsForCompletion False
#else
ghcCmdOptions = [ "-f" ++ prefix ++ option
                | option <- opts
                , prefix <- ["","no-"]
                ]
#  if __GLASGOW_HASKELL__ >= 704
 where opts =
           [option | (option,_,_) <- fFlags]
        ++ [option | (option,_,_) <- fWarningFlags]
        ++ [option | (option,_,_) <- fLangFlags]
#  else
 where opts =
           [option | (option,_,_,_) <- fFlags]
        ++ [option | (option,_,_,_) <- fWarningFlags]
        ++ [option | (option,_,_,_) <- fLangFlags]
#  endif
#endif

----------------------------------------------------------------
----------------------------------------------------------------

fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file' = do
    mss <- getModuleGraph
    file <- liftIO $ canonicalizePath file'
    [ms] <- liftIO $ flip filterM mss $ \m ->
        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
    return ms

withInteractiveContext :: GhcMonad m => m a -> m a
withInteractiveContext action = gbracket setup teardown body
  where
    setup = getContext
    teardown = setCtx
    body _ = do
        topImports >>= setCtx
        action
    topImports = do
        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph
        let iis = map (IIModule . modName) ms
#if __GLASGOW_HASKELL__ >= 704
        return iis
#else
        return (iis,[])
#endif
#if __GLASGOW_HASKELL__ >= 706
    modName = moduleName
    setCtx = setContext
#elif __GLASGOW_HASKELL__ >= 704
    modName = id
    setCtx = setContext
#else
    modName = ms_mod
    setCtx = uncurry setContext
#endif

showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning: "
showSeverityCaption _          = ""
#else
showSeverityCaption = const ""
#endif

----------------------------------------------------------------
----------------------------------------------------------------

setCabalPkg :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
#else
setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
#endif

----------------------------------------------------------------

setHideAllPackages :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setHideAllPackages df = gopt_set df Opt_HideAllPackages
#else
setHideAllPackages df = dopt_set df Opt_HideAllPackages
#endif

----------------------------------------------------------------

setDumpSplices :: DynFlags -> DynFlags
setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices

isDumpSplices :: DynFlags -> Bool
isDumpSplices dflag = dopt Opt_D_dump_splices dflag

----------------------------------------------------------------


setDeferTypeErrors :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors
#elif __GLASGOW_HASKELL__ >= 706
setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
#else
setDeferTypeErrors = id
#endif

setDeferTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 710
setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles
#else
setDeferTypedHoles = id
#endif

setWarnTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
#else
setWarnTypedHoles = id
#endif

----------------------------------------------------------------

-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif

----------------------------------------------------------------
----------------------------------------------------------------

class HasType a where
    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))


instance HasType (LHsBind Id) where
#if __GLASGOW_HASKELL__ >= 708
    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)
      where in_tys = mg_arg_tys m
            out_typ = mg_res_ty m
            typ = mkFunTys in_tys out_typ
#else
    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
#endif
    getType _ _ = return Nothing

----------------------------------------------------------------
----------------------------------------------------------------
-- from ghc/InteractiveUI.hs

filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
  where
    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]

infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
infoThing m (Expression str) = do
    names <- parseName str
#if __GLASGOW_HASKELL__ >= 708
    mb_stuffs <- mapM (getInfo False) names
    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
#else
    mb_stuffs <- mapM getInfo names
    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif
    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)

#if __GLASGOW_HASKELL__ >= 708
pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo m _ (thing, fixity, insts, famInsts)
    = pprTyThingInContextLoc' thing
   $$ show_fixity fixity
   $$ vcat (map pprInstance' insts)
   $$ vcat (map pprFamInst' famInsts)
#else
pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo m pefas (thing, fixity, insts)
    = pprTyThingInContextLoc' pefas thing
   $$ show_fixity fixity
   $$ vcat (map pprInstance' insts)
#endif
  where
    show_fixity fx
      | fx == defaultFixity = Outputable.empty
      | otherwise           = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708
    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
#if __GLASGOW_HASKELL__ >= 710
    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
      = pprTyThingInContextLoc (ATyCon rep_tc)

    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
                        , fi_tys = lhs_tys, fi_rhs = rhs })
      = showWithLoc (pprDefinedAt' (getName axiom)) $
        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
           2 (equals <+> ppr rhs)
#else
    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
#endif
#else
    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
#endif
    showWithLoc loc doc
        = hang doc 2 (char '\t' <> comment <+> loc)
        -- The tab tries to make them line up a bit
      where
        comment = ptext (sLit "--")
    pprInstance' ispec = hang (pprInstanceHdr ispec)
        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
    pprNameDefnLoc' name
      = case Name.nameSrcLoc name of
           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
           UnhelpfulLoc s
             | Name.isInternalName name || Name.isSystemName name
             -> ptext (sLit "at") <+> ftext s
             | otherwise
             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))
      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)
            realFP = mkFastString . m . unpackFS . srcLocFile

----------------------------------------------------------------
----------------------------------------------------------------

errorMsgSpan :: ErrMsg -> SrcSpan
#if __GLASGOW_HASKELL__ >= 708
errorMsgSpan = errMsgSpan
#else
errorMsgSpan = head . errMsgSpans
#endif

setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg
#if __GLASGOW_HASKELL__ >= 708
setErrorMsgSpan err s = err { errMsgSpan = s }
#else
setErrorMsgSpan err s = err { errMsgSpans = [s] }
#endif

typeForUser :: Type -> SDoc
#if __GLASGOW_HASKELL__ >= 708
typeForUser = pprTypeForUser
#else
typeForUser = pprTypeForUser False
#endif

nameForUser :: Name -> SDoc
nameForUser = pprOccName . getOccName

occNameForUser :: OccName -> SDoc
occNameForUser = pprOccName

deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
         -> IO (Maybe CoreExpr)
#if __GLASGOW_HASKELL__ >= 708
deSugar _   e hs_env = snd <$> deSugarExpr hs_env e
#else
deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e
  where
    modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
    tcgEnv = fst $ tm_internals_ tcm
    rn_env = tcg_rdr_env tcgEnv
    ty_env = tcg_type_env tcgEnv
#endif

----------------------------------------------------------------
----------------------------------------------------------------

data GapThing = GtA Type
              | GtT TyCon
              | GtN
#if __GLASGOW_HASKELL__ >= 800
              | GtPatSyn PatSyn
#endif

fromTyThing :: TyThing -> GapThing
fromTyThing (AnId i)                   = GtA $ varType i
#if __GLASGOW_HASKELL__ >= 708
fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d
#if __GLASGOW_HASKELL__ >= 800
fromTyThing (AConLike (PatSynCon p))   = GtPatSyn p
#else
fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p
#endif
#else
fromTyThing (ADataCon d)               = GtA $ dataConUserType d
#endif
fromTyThing (ATyCon t)                 = GtT t
fromTyThing _                          = GtN

----------------------------------------------------------------
----------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 704
type WarnFlags = I.IntSet
emptyWarnFlags :: WarnFlags
emptyWarnFlags = I.empty
#else
type WarnFlags = [WarningFlag]
emptyWarnFlags :: WarnFlags
emptyWarnFlags = []
#endif

----------------------------------------------------------------
----------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 708
type GLMatch = LMatch RdrName (LHsExpr RdrName)
type GLMatchI = LMatch Id (LHsExpr Id)
#else
type GLMatch = LMatch RdrName
type GLMatchI = LMatch Id
#endif

getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
#if __GLASGOW_HASKELL__ >= 800
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 710
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 708
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 706
getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#else
getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#endif
getClass _ = Nothing

#if __GLASGOW_HASKELL__ < 706
occName :: RdrName -> OccName
occName = rdrNameOcc
#endif

----------------------------------------------------------------

#if __GLASGOW_HASKELL__ < 710
-- Copied from ghc/InteractiveUI.hs
allExposedPackageConfigs :: DynFlags -> [PackageConfig]
allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df

allExposedModules :: DynFlags -> [ModuleName]
allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df

listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames = allExposedModules
#endif

lookupModulePackageInAllPackages ::
    DynFlags -> ModuleName -> [String]
lookupModulePackageInAllPackages df mn =
#if __GLASGOW_HASKELL__ >= 710
    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn
 where
   unpackSPId (SourcePackageId fs) = unpackFS fs
#else
    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn
 where
   unpackPId pid = packageIdString $ mkPackageId pid
--       n ++ "-" ++ showVersion v
#endif

listVisibleModules :: DynFlags -> [GHC.Module]
listVisibleModules df = let
#if __GLASGOW_HASKELL__ >= 710
    modNames = listVisibleModuleNames df
    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
#else
    pkgCfgs = allExposedPackageConfigs df
    mods = [ mkModule pid modname | p <- pkgCfgs
           , let pid = packageConfigId p
           , modname <- exposedModules p ]
#endif
    in mods

isSynTyCon :: TyCon -> Bool
#if __GLASGOW_HASKELL__ >= 710
isSynTyCon = GHC.isTypeSynonymTyCon
#else
isSynTyCon = GHC.isSynTyCon
#endif


parseModuleHeader
    :: String         -- ^ Haskell module source text (full Unicode is supported)
    -> DynFlags
    -> FilePath       -- ^ the filename (for source locations)
    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
parseModuleHeader str dflags filename =
   let
       loc  = mkRealSrcLoc (mkFastString filename) 1 1
       buf  = stringToStringBuffer str
   in
   case L.unP Parser.parseHeader (mkPState dflags buf loc) of

     PFailed sp err   ->
#if __GLASGOW_HASKELL__ >= 706
         Left (unitBag (mkPlainErrMsg dflags sp err))
#else
         Left (unitBag (mkPlainErrMsg sp err))
#endif

     POk pst rdr_module ->
         let (warns,_) = getMessages pst in
         Right (warns, rdr_module)

mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle
#if __GLASGOW_HASKELL__ >= 706
mkErrStyle' = Outputable.mkErrStyle
#else
mkErrStyle' _ = Outputable.mkErrStyle
#endif

#if __GLASGOW_HASKELL__ < 706
instance NFData ByteString where
  rnf Empty       = ()
  rnf (Chunk _ b) = rnf b
#endif

-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
--   generated the Ast.
everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r
everythingStagedWithContext stage s0 f z q x
  | (const False
#if __GLASGOW_HASKELL__ <= 708
      `extQ` postTcType
#endif
      `extQ` fixity `extQ` nameSet) x = z
  | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)
  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
#endif
        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
        (r, s') = q x s0

withCleanupSession :: GhcMonad m => m a -> m a
#if __GLASGOW_HASKELL__ >= 800
#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
withCleanupSession = GHC.withCleanupSession
#else
withCleanupSession ghc = ghc `gfinally` cleanup
  where
   cleanup = do
      hsc_env <- getSession
      let dflags = hsc_dflags hsc_env
      liftIO $ do
          cleanTempFiles dflags
          cleanTempDirs dflags
          stopIServ hsc_env
#endif
#else
withCleanupSession action = do
  df <- getSessionDynFlags
  GHC.defaultCleanupHandler df action
#endif