ghc-mod/core/Language/Haskell/GhcMod/Gap.hs

722 lines
22 KiB
Haskell
Raw Normal View History

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}
2012-02-14 07:09:53 +00:00
2013-05-17 01:00:01 +00:00
module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget
2013-03-12 13:15:23 +00:00
, withStyle
2015-09-11 02:13:44 +00:00
, GmLogAction
, setLogAction
2012-02-14 07:09:53 +00:00
, getSrcSpan
, getSrcFile
, withInteractiveContext
, ghcCmdOptions
2012-02-14 07:09:53 +00:00
, toStringBuffer
, showSeverityCaption
, setCabalPkg
2014-04-23 01:41:28 +00:00
, setHideAllPackages
2014-04-26 04:21:22 +00:00
, setDeferTypeErrors
2015-07-11 10:47:03 +00:00
, setDeferTypedHoles
2014-06-09 08:30:33 +00:00
, setWarnTypedHoles
2014-04-26 04:21:22 +00:00
, setDumpSplices
, setNoMaxRelevantBindings
2014-04-26 04:21:22 +00:00
, isDumpSplices
, filterOutChildren
, infoThing
, pprInfo
, HasType(..)
2013-11-19 03:28:59 +00:00
, errorMsgSpan
, setErrorMsgSpan
2013-11-19 03:35:42 +00:00
, typeForUser
, nameForUser
, occNameForUser
2013-11-19 03:54:08 +00:00
, deSugar
, showDocWith
2016-12-15 18:16:37 +00:00
, render
2014-02-06 12:34:40 +00:00
, GapThing(..)
, fromTyThing
2014-04-27 12:26:03 +00:00
, fileModSummary
2014-04-28 05:36:55 +00:00
, WarnFlags
, emptyWarnFlags
2014-07-15 03:35:45 +00:00
, GLMatch
, GLMatchI
2014-07-15 05:44:02 +00:00
, getClass
, occName
2015-01-16 14:47:56 +00:00
, listVisibleModuleNames
, listVisibleModules
, lookupModulePackageInAllPackages
2015-01-16 14:47:56 +00:00
, Language.Haskell.GhcMod.Gap.isSynTyCon
2015-03-05 15:50:06 +00:00
, parseModuleHeader
2015-08-19 06:11:29 +00:00
, mkErrStyle'
, everythingStagedWithContext
, withCleanupSession
2012-02-14 07:09:53 +00:00
) where
import Control.Applicative hiding (empty)
2014-03-27 07:02:16 +00:00
import Control.Monad (filterM)
import CoreSyn (CoreExpr)
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import Data.Time.Clock (UTCTime)
2015-08-03 05:51:23 +00:00
import Data.Traversable hiding (mapM)
import DataCon (dataConUserType)
2013-11-19 03:54:08 +00:00
import Desugar (deSugarExpr)
2012-02-14 07:09:53 +00:00
import DynFlags
import ErrUtils
import Exception
2012-02-14 07:09:53 +00:00
import FastString
import GhcMonad
2013-07-14 08:07:30 +00:00
import HscTypes
import NameSet
import OccName
2012-02-14 07:09:53 +00:00
import Outputable
2013-07-14 08:07:30 +00:00
import PprTyThing
2012-02-14 07:09:53 +00:00
import StringBuffer
import TcType
2014-02-06 13:09:00 +00:00
import Var (varType)
import System.Directory
import SysTools
2016-07-16 01:53:57 +00:00
#if __GLASGOW_HASKELL__ >= 800
import GHCi (stopIServ)
2016-07-16 01:53:57 +00:00
#endif
2015-01-16 14:47:56 +00:00
2015-07-04 14:49:48 +00:00
import qualified Name
import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB
2014-04-28 05:13:25 +00:00
#if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon)
#endif
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
import PatSyn
2014-01-08 00:55:06 +00:00
#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
2016-11-30 12:46:14 +00:00
#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
2016-10-20 13:41:31 +00:00
import GHC hiding (ClsInst, withCleanupSession)
import qualified GHC (withCleanupSession)
2016-10-22 14:40:00 +00:00
#elif __GLASGOW_HASKELL__ >= 706
import GHC hiding (ClsInst)
#else
import GHC hiding (Instance)
2013-07-02 09:29:08 +00:00
import Control.Arrow hiding ((<+>))
import Data.Convertible
2014-07-15 05:44:02 +00:00
import RdrName (rdrNameOcc)
#endif
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ < 710
import UniqFM (eltsUFM)
import Module
2015-01-16 14:47:56 +00:00
#endif
2014-04-28 05:36:55 +00:00
#if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
#endif
2016-01-09 15:51:18 +00:00
#if __GLASGOW_HASKELL__ < 706
import Control.DeepSeq (NFData(rnf))
import Data.ByteString.Lazy.Internal (ByteString(..))
#endif
2015-03-05 15:50:06 +00:00
import Bag
import Lexer as L
import Parser
import SrcLoc
import Packages
import Data.Generics (GenericQ, extQ, gmapQ)
import GHC.SYB.Utils (Stage(..))
2015-03-05 15:50:06 +00:00
import Language.Haskell.GhcMod.Types (Expression(..))
2015-08-03 01:09:56 +00:00
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
----------------------------------------------------------------
----------------------------------------------------------------
2013-03-12 13:15:23 +00:00
withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc
#if __GLASGOW_HASKELL__ >= 706
2013-03-12 13:15:23 +00:00
withStyle = withPprStyleDoc
#else
2013-03-12 13:15:23 +00:00
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
2015-09-11 02:13:44 +00:00
#else
type GmLogAction = forall a. a -> DynFlags -> LogAction
2015-09-11 02:13:44 +00:00
#endif
-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
2015-09-11 02:13:44 +00:00
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
2016-02-04 18:54:55 +00:00
#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
2016-12-15 18:16:37 +00:00
render :: Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
render = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
#else
render = 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.ZStr s1) s2 = zString s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
2012-02-14 07:09:53 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
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
2012-02-14 07:09:53 +00:00
#if __GLASGOW_HASKELL__ >= 702
toStringBuffer = return . stringToStringBuffer . unlines
#else
toStringBuffer = liftIO . stringToStringBuffer . unlines
#endif
----------------------------------------------------------------
ghcCmdOptions :: [String]
2015-01-16 14:47:56 +00:00
#if __GLASGOW_HASKELL__ >= 710
-- this also includes -X options and all sorts of other things so the
ghcCmdOptions = flagsForCompletion False
2016-02-04 18:54:55 +00:00
#else
ghcCmdOptions = [ "-f" ++ prefix ++ option
| option <- opts
, prefix <- ["","no-"]
]
# if __GLASGOW_HASKELL__ >= 704
where opts =
[option | (option,_,_) <- fFlags]
2012-06-07 06:56:55 +00:00
++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags]
# else
where opts =
[option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags]
# endif
2012-02-14 07:09:53 +00:00
#endif
----------------------------------------------------------------
----------------------------------------------------------------
fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file' = do
2014-04-27 12:26:03 +00:00
mss <- getModuleGraph
file <- liftIO $ canonicalizePath file'
[ms] <- liftIO $ flip filterM mss $ \m ->
(Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
2014-04-27 12:26:03 +00:00
return ms
withInteractiveContext :: GhcMonad m => m a -> m a
withInteractiveContext action = gbracket setup teardown body
2014-04-27 12:26:03 +00:00
where
setup = getContext
2014-04-28 00:28:57 +00:00
teardown = setCtx
2014-04-27 12:26:03 +00:00
body _ = do
2014-04-28 00:00:03 +00:00
topImports >>= setCtx
2014-04-27 12:26:03 +00:00
action
topImports = do
ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph
let iis = map (IIModule . modName) ms
2014-04-28 02:26:06 +00:00
#if __GLASGOW_HASKELL__ >= 704
return iis
2014-04-28 02:26:06 +00:00
#else
return (iis,[])
2014-04-28 02:26:06 +00:00
#endif
#if __GLASGOW_HASKELL__ >= 706
modName = moduleName
2014-04-28 00:00:03 +00:00
setCtx = setContext
2014-04-27 12:26:03 +00:00
#elif __GLASGOW_HASKELL__ >= 704
modName = id
2014-04-28 00:00:03 +00:00
setCtx = setContext
2012-02-14 07:09:53 +00:00
#else
2014-04-28 00:00:03 +00:00
modName = ms_mod
2014-04-28 02:26:06 +00:00
setCtx = uncurry setContext
2012-02-14 07:09:53 +00:00
#endif
showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning: "
showSeverityCaption _ = ""
#else
showSeverityCaption = const ""
#endif
----------------------------------------------------------------
----------------------------------------------------------------
setCabalPkg :: DynFlags -> DynFlags
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
#else
setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
#endif
----------------------------------------------------------------
2014-04-23 01:41:28 +00:00
setHideAllPackages :: DynFlags -> DynFlags
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-04-26 04:21:22 +00:00
setHideAllPackages df = gopt_set df Opt_HideAllPackages
2013-07-14 08:07:30 +00:00
#else
2014-04-26 04:21:22 +00:00
setHideAllPackages df = dopt_set df Opt_HideAllPackages
2013-07-14 08:07:30 +00:00
#endif
2014-04-23 01:41:28 +00:00
2014-04-26 04:21:22 +00:00
----------------------------------------------------------------
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
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-04-26 04:21:22 +00:00
setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors
#elif __GLASGOW_HASKELL__ >= 706
setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
#else
setDeferTypeErrors = id
#endif
2015-07-11 10:47:03 +00:00
setDeferTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 710
2015-07-11 10:47:03 +00:00
setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles
#else
setDeferTypedHoles = id
#endif
2014-06-09 08:30:33 +00:00
setWarnTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
#else
setWarnTypedHoles = id
2014-04-26 04:21:22 +00:00
#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
2014-04-28 05:04:18 +00:00
#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
2013-07-14 08:07:30 +00:00
#else
getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
2013-07-14 08:07:30 +00:00
#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)]
2015-07-04 14:49:48 +00:00
infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
infoThing m (Expression str) = do
names <- parseName str
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names
let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
2013-07-14 08:07:30 +00:00
#else
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif
2015-07-04 14:49:48 +00:00
return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2015-07-04 14:49:48 +00:00
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)
2013-07-14 08:07:30 +00:00
#else
2015-07-04 14:49:48 +00:00
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)
2015-07-04 14:49:48 +00:00
#endif
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
2015-07-04 14:49:48 +00:00
#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
2015-07-04 14:49:48 +00:00
#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')
2015-07-04 14:49:48 +00:00
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
2013-11-12 23:44:34 +00:00
2013-11-19 03:28:59 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
errorMsgSpan :: ErrMsg -> SrcSpan
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2013-11-19 03:28:59 +00:00
errorMsgSpan = errMsgSpan
#else
errorMsgSpan = head . errMsgSpans
#endif
2013-11-19 03:35:42 +00:00
setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg
#if __GLASGOW_HASKELL__ >= 708
setErrorMsgSpan err s = err { errMsgSpan = s }
#else
setErrorMsgSpan err s = err { errMsgSpans = [s] }
#endif
2013-11-19 03:35:42 +00:00
typeForUser :: Type -> SDoc
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2013-11-19 03:35:42 +00:00
typeForUser = pprTypeForUser
#else
typeForUser = pprTypeForUser False
#endif
2013-11-19 03:54:08 +00:00
nameForUser :: Name -> SDoc
nameForUser = pprOccName . getOccName
occNameForUser :: OccName -> SDoc
occNameForUser = pprOccName
2013-11-19 03:54:08 +00:00
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
2014-03-27 07:02:16 +00:00
-> IO (Maybe CoreExpr)
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
2014-01-08 00:55:06 +00:00
deSugar _ e hs_env = snd <$> deSugarExpr hs_env e
2013-11-19 03:54:08 +00:00
#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
2014-02-06 12:34:40 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
data GapThing = GtA Type
| GtT TyCon
| GtN
2016-05-19 16:25:05 +00:00
#if __GLASGOW_HASKELL__ >= 800
| GtPatSyn PatSyn
2016-05-19 16:25:05 +00:00
#endif
2014-02-06 12:34:40 +00:00
fromTyThing :: TyThing -> GapThing
2014-02-06 13:09:00 +00:00
fromTyThing (AnId i) = GtA $ varType i
2014-04-28 05:04:18 +00:00
#if __GLASGOW_HASKELL__ >= 708
fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d
2016-05-19 16:25:05 +00:00
#if __GLASGOW_HASKELL__ >= 800
fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p
#else
2014-02-06 13:09:00 +00:00
fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p
2016-05-19 16:25:05 +00:00
#endif
#else
fromTyThing (ADataCon d) = GtA $ dataConUserType d
#endif
fromTyThing (ATyCon t) = GtT t
fromTyThing _ = GtN
2014-04-28 05:36:55 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 704
type WarnFlags = I.IntSet
emptyWarnFlags :: WarnFlags
emptyWarnFlags = I.empty
#else
type WarnFlags = [WarningFlag]
emptyWarnFlags :: WarnFlags
emptyWarnFlags = []
#endif
2014-07-15 03:29:27 +00:00
----------------------------------------------------------------
----------------------------------------------------------------
2014-07-15 03:35:45 +00:00
#if __GLASGOW_HASKELL__ >= 708
type GLMatch = LMatch RdrName (LHsExpr RdrName)
type GLMatchI = LMatch Id (LHsExpr Id)
2014-07-15 03:35:45 +00:00
#else
type GLMatch = LMatch RdrName
type GLMatchI = LMatch Id
2014-07-15 03:35:45 +00:00
#endif
2014-07-15 05:44:02 +00:00
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
2016-02-04 18:54:55 +00:00
#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
2015-01-16 14:47:56 +00:00
-- 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
2014-07-15 05:44:02 +00:00
-- 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
2014-07-15 06:13:06 +00:00
occName :: RdrName -> OccName
2014-07-15 05:44:02 +00:00
occName = rdrNameOcc
#endif
2014-07-18 02:09:11 +00:00
----------------------------------------------------------------
2015-01-16 14:47:56 +00:00
#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
2015-01-16 14:47:56 +00:00
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
2015-03-05 15:50:06 +00:00
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)
2015-08-19 06:11:29 +00:00
mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle
#if __GLASGOW_HASKELL__ >= 706
mkErrStyle' = Outputable.mkErrStyle
#else
mkErrStyle' _ = Outputable.mkErrStyle
#endif
2016-01-09 15:51:18 +00:00
#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
2016-11-30 12:46:14 +00:00
#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
2016-10-20 13:41:31 +00:00
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
2016-10-20 13:41:31 +00:00
#endif
#else
withCleanupSession action = do
df <- getSessionDynFlags
GHC.defaultCleanupHandler df action
#endif