{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 900
{-# LANGUAGE PatternSynonyms #-}
#define CPP_GhcPlugins GHC.Plugins
#define CPP_InstEnv GHC.Core.InstEnv
#define CPP_TyCoRep GHC.Core.TyCo.Rep
#define CPP_ErrUtils GHC.Utils.Error
#else
#define CPP_GhcPlugins GhcPlugins
#define CPP_InstEnv InstEnv
#define CPP_TyCoRep TyCoRep
#define CPP_ErrUtils ErrUtils
#endif
module Data.Constraint.Deriving.Compat where
import CPP_GhcPlugins
( Id,DFunId, Type, Coercion, SrcSpan, SDoc
, PrintUnqualified, Name, ModSummary, WarnReason
, DynFlags, Role, UniqFM
, splitFunTys, coreView, mkWildValBinder
, mkLocalIdOrCoVar, mkLocalId, isBootSummary
, mkUnivCo, typeKind
#if __GLASGOW_HASKELL__ >= 900
, Mult, Unique, IsBootInterface(NotBoot)
, pattern Many, irrelevantMult
#else
, mkErrStyle
#if __GLASGOW_HASKELL__ >= 810
, mkInvisFunTys
#endif
#endif
#if __GLASGOW_HASKELL__ >= 810
, AnonArgFlag(..)
#else
, splitFunTy_maybe, mkFunTys
#endif
#if __GLASGOW_HASKELL__ >= 806
, tcIsConstraintKind
#else
, Kind, HscEnv, Module, OccName
#endif
#if __GLASGOW_HASKELL__ >= 802
, idName, putLogMsg
#else
, Expr(..), TCvSubst, UniqSet
, isCoercionTy_maybe, unicodeSyntax, char, flSelector, log_action
#endif
)
import CPP_InstEnv (ClsInst(..))
import CPP_TyCoRep
( UnivCoProvenance(PluginProv)
#if __GLASGOW_HASKELL__ >= 810
, Type (FunTy)
#endif
, mkFunTy
)
import CPP_ErrUtils (Severity)
#if __GLASGOW_HASKELL__ < 806
import Kind (isConstraintKind)
import IfaceEnv (lookupOrig)
import TcRnMonad (initTcForLookup)
#endif
#if __GLASGOW_HASKELL__ < 802
import Avail (AvailInfo(..))
import Unify (tcMatchTy)
#endif
#if __GLASGOW_HASKELL__ >= 900
type UniqMap = UniqFM Unique
#else
type UniqMap = UniqFM
#endif
#if __GLASGOW_HASKELL__ < 900
data Mult = One | Many
mkInvisFunTysMany :: [Type] -> Type -> Type
#if __GLASGOW_HASKELL__ < 810
mkInvisFunTysMany = mkFunTys
#else
mkInvisFunTysMany :: [Type] -> Type -> Type
mkInvisFunTysMany = [Type] -> Type -> Type
mkInvisFunTys
#endif
#endif
#if __GLASGOW_HASKELL__ < 810
data AnonArgFlag = VisArg | InvisArg
#endif
#if __GLASGOW_HASKELL__ < 802
uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool
uniqSetAny g = foldl (\a -> (||) a . g) False
mkTyArg :: Type -> Expr b
mkTyArg ty
| Just co <- isCoercionTy_maybe ty = Coercion co
| otherwise = Type ty
bullet :: SDoc
bullet = unicodeSyntax (char '•') (char '*')
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails _ [] = []
filterAvails keep (a:as) = case go a of
Nothing -> filterAvails keep as
Just fa -> fa : filterAvails keep as
where
go x@(Avail _ n)
| keep n = Just x
| otherwise = Nothing
go (AvailTC n ns fs) =
let ns' = filter keep ns
fs' = filter (keep . flSelector) fs
in if null ns' && null fs'
then Nothing
else Just $ AvailTC n ns' fs'
tcMatchTyKi :: Type -> Type -> Maybe TCvSubst
tcMatchTyKi = tcMatchTy
#endif
#if __GLASGOW_HASKELL__ < 806
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO hscEnv m = initTcForLookup hscEnv . lookupOrig m
tcIsConstraintKind :: Kind -> Bool
tcIsConstraintKind = isConstraintKind
#endif
mkLocalIdCompat :: Name -> Mult -> Type -> Id
#if __GLASGOW_HASKELL__ >= 900
mkLocalIdCompat = mkLocalId
#else
mkLocalIdCompat :: Name -> Mult -> Type -> Id
mkLocalIdCompat Name
name Mult
_ = Name -> Type -> Id
mkLocalId Name
name
#endif
mkLocalIdOrCoVarCompat :: Name -> Mult -> Type -> Id
#if __GLASGOW_HASKELL__ >= 900
mkLocalIdOrCoVarCompat = mkLocalIdOrCoVar
#else
mkLocalIdOrCoVarCompat :: Name -> Mult -> Type -> Id
mkLocalIdOrCoVarCompat Name
name Mult
_ = Name -> Type -> Id
mkLocalIdOrCoVar Name
name
#endif
setClsInstDfunId :: DFunId -> ClsInst -> ClsInst
setClsInstDfunId :: Id -> ClsInst -> ClsInst
setClsInstDfunId Id
dFunId ClsInst
i = ClsInst
i
{ is_dfun :: Id
is_dfun = Id
dFunId
#if __GLASGOW_HASKELL__ >= 802
, is_dfun_name :: Name
is_dfun_name = Id -> Name
idName Id
dFunId
#endif
}
mkPluginCo :: String -> Role -> Type -> Type -> Coercion
mkPluginCo :: String -> Role -> Type -> Type -> Coercion
mkPluginCo String
reason = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo (String -> UnivCoProvenance
PluginProv (String -> UnivCoProvenance) -> String -> UnivCoProvenance
forall a b. (a -> b) -> a -> b
$ String
"constraints-deriving: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason)
mkFunTyCompat :: AnonArgFlag -> Mult -> Type -> Type -> Type
#if __GLASGOW_HASKELL__ >= 900
mkFunTyCompat = mkFunTy
#elif __GLASGOW_HASKELL__ >= 810
mkFunTyCompat :: AnonArgFlag -> Mult -> Type -> Type -> Type
mkFunTyCompat AnonArgFlag
f Mult
_ = AnonArgFlag -> Type -> Type -> Type
mkFunTy AnonArgFlag
f
#else
mkFunTyCompat _ _ = mkFunTy
#endif
splitFunTyCompat :: Type -> Maybe (AnonArgFlag, Mult, Type, Type)
#if __GLASGOW_HASKELL__ >= 900
splitFunTyCompat (FunTy vis mult arg res)
= Just (vis, mult, arg, res)
#elif __GLASGOW_HASKELL__ >= 810
splitFunTyCompat :: Type -> Maybe (AnonArgFlag, Mult, Type, Type)
splitFunTyCompat (FunTy AnonArgFlag
vis Type
arg Type
res)
= (AnonArgFlag, Mult, Type, Type)
-> Maybe (AnonArgFlag, Mult, Type, Type)
forall a. a -> Maybe a
Just (AnonArgFlag
vis, Mult
Many, Type
arg, Type
res)
#else
splitFunTyCompat ty | Just (arg, res) <- splitFunTy_maybe ty
= Just (mkConstraintInvis arg VisArg, Many, arg, res)
#endif
splitFunTyCompat Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (AnonArgFlag, Mult, Type, Type)
splitFunTyCompat Type
ty'
splitFunTyCompat Type
_ = Maybe (AnonArgFlag, Mult, Type, Type)
forall a. Maybe a
Nothing
splitFunTysCompat :: Type -> ([Type], Type)
#if __GLASGOW_HASKELL__ >= 900
splitFunTysCompat t = (map irrelevantMult ts, r)
where
(ts, r) = splitFunTys t
#else
splitFunTysCompat :: Type -> ([Type], Type)
splitFunTysCompat = Type -> ([Type], Type)
splitFunTys
#endif
mkConstraintInvis :: Type -> AnonArgFlag -> AnonArgFlag
mkConstraintInvis :: Type -> AnonArgFlag -> AnonArgFlag
mkConstraintInvis Type
arg AnonArgFlag
vis = if Type -> Bool
tcIsConstraintKind (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
arg) then AnonArgFlag
InvisArg else AnonArgFlag
vis
mkWildValBinderCompat :: Type -> Id
#if __GLASGOW_HASKELL__ >= 900
mkWildValBinderCompat = mkWildValBinder Many
#else
mkWildValBinderCompat :: Type -> Id
mkWildValBinderCompat = Type -> Id
mkWildValBinder
#endif
isNotBootFile :: ModSummary -> Bool
#if __GLASGOW_HASKELL__ >= 900
isNotBootFile = (NotBoot ==) . isBootSummary
#else
isNotBootFile :: ModSummary -> Bool
isNotBootFile = Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
isBootSummary
#endif
putLogMsgCompat :: DynFlags -> WarnReason -> Severity
-> SrcSpan -> PrintUnqualified -> SDoc -> IO ()
#if __GLASGOW_HASKELL__ >= 900
putLogMsgCompat df wr se ss _ = putLogMsg df wr se ss
#elif __GLASGOW_HASKELL__ >= 802
putLogMsgCompat :: DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> PrintUnqualified
-> SDoc
-> IO ()
putLogMsgCompat DynFlags
df WarnReason
wr Severity
se SrcSpan
ss PrintUnqualified
pu = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
df WarnReason
wr Severity
se SrcSpan
ss (DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle DynFlags
df PrintUnqualified
pu)
#else
putLogMsgCompat df wr se ss pu = log_action df df wr se ss (mkErrStyle df pu)
#endif