{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
#include "GhclibHsVersions.h"
import GhcPrelude
import HsSyn
import DynFlags
import TcRnMonad
import FamInst
import TcDerivInfer
import TcDerivUtils
import TcValidity( allDistinctTyVars )
import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
import TcEnv
import TcGenDeriv
import TcValidity( checkValidInstHead )
import InstEnv
import Inst
import FamInstEnv
import TcHsType
import TyCoRep
import RnNames( extendGlobalRdrEnvRn )
import RnBinds
import RnEnv
import RnUtils ( bindLocalNamesFV )
import RnSource ( addTcgDUs )
import Avail
import Unify( tcUnifyTy )
import Class
import Type
import ErrUtils
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarEnv
import VarSet
import PrelNames
import SrcLoc
import Util
import Outputable
import FastString
import Bag
import Pair
import FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List
data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
| GivenTheta (DerivSpec ThetaType)
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta DerivSpec [ThetaOrigin]
spec) = DerivSpec [ThetaOrigin] -> SrcSpan
forall theta. DerivSpec theta -> SrcSpan
ds_loc DerivSpec [ThetaOrigin]
spec
earlyDSLoc (GivenTheta DerivSpec ThetaType
spec) = DerivSpec ThetaType -> SrcSpan
forall theta. DerivSpec theta -> SrcSpan
ds_loc DerivSpec ThetaType
spec
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta DerivSpec [ThetaOrigin]
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec [ThetaOrigin]]
is, [DerivSpec ThetaType]
gs) -> (DerivSpec [ThetaOrigin]
spec DerivSpec [ThetaOrigin]
-> [DerivSpec [ThetaOrigin]] -> [DerivSpec [ThetaOrigin]]
forall a. a -> [a] -> [a]
: [DerivSpec [ThetaOrigin]]
is, [DerivSpec ThetaType]
gs)
splitEarlyDerivSpec (GivenTheta DerivSpec ThetaType
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec [ThetaOrigin]]
is, [DerivSpec ThetaType]
gs) -> ([DerivSpec [ThetaOrigin]]
is, DerivSpec ThetaType
spec DerivSpec ThetaType
-> [DerivSpec ThetaType] -> [DerivSpec ThetaType]
forall a. a -> [a] -> [a]
: [DerivSpec ThetaType]
gs)
instance Outputable EarlyDerivSpec where
ppr :: EarlyDerivSpec -> SDoc
ppr (InferTheta DerivSpec [ThetaOrigin]
spec) = DerivSpec [ThetaOrigin] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec [ThetaOrigin]
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(Infer)"
ppr (GivenTheta DerivSpec ThetaType
spec) = DerivSpec ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaType
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(Given)"
data DerivInfo = DerivInfo { DerivInfo -> TyCon
di_rep_tc :: TyCon
, DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses :: [LHsDerivingClause GhcRn]
, DerivInfo -> SDoc
di_ctxt :: SDoc
}
mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
mkDerivInfos [LTyClDecl GhcRn]
decls = (LTyClDecl GhcRn -> TcM [DerivInfo])
-> [LTyClDecl GhcRn] -> TcM [DerivInfo]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (TyClDecl GhcRn -> TcM [DerivInfo]
mk_deriv (TyClDecl GhcRn -> TcM [DerivInfo])
-> (LTyClDecl GhcRn -> TyClDecl GhcRn)
-> LTyClDecl GhcRn
-> TcM [DerivInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LTyClDecl GhcRn]
decls
where
mk_deriv :: TyClDecl GhcRn -> TcM [DerivInfo]
mk_deriv decl :: TyClDecl GhcRn
decl@(DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = L SrcSpan
_ IdP GhcRn
data_name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn =
HsDataDefn { dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = L SrcSpan
_ [LHsDerivingClause GhcRn]
clauses } })
= do { TyCon
tycon <- Name -> TcM TyCon
tcLookupTyCon IdP GhcRn
Name
data_name
; [DerivInfo] -> TcM [DerivInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [DerivInfo :: TyCon -> [LHsDerivingClause GhcRn] -> SDoc -> DerivInfo
DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon, di_clauses :: [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
, di_ctxt :: SDoc
di_ctxt = TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl }] }
mk_deriv TyClDecl GhcRn
_ = [DerivInfo] -> TcM [DerivInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcDeriving :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (do { TcGblEnv
g <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
g, Bag (InstInfo GhcRn)
forall a. Bag a
emptyBag, HsValBinds GhcRn
forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut)}) (TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn))
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a b. (a -> b) -> a -> b
$
do {
Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; String -> SDoc -> TcRn ()
traceTc String
"tcDeriving" (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
is_boot)
; [EarlyDerivSpec]
early_specs <- Bool -> [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs Bool
is_boot [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
; String -> SDoc -> TcRn ()
traceTc String
"tcDeriving 1" ([EarlyDerivSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EarlyDerivSpec]
early_specs)
; let ([DerivSpec [ThetaOrigin]]
infer_specs, [DerivSpec ThetaType]
given_specs) = [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
early_specs
; [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 <- (DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec ThetaType]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec ThetaType]
given_specs
; [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2 <- (DerivSpec [ThetaOrigin]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec [ThetaOrigin]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec [ThetaOrigin]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec [ThetaOrigin]]
infer_specs
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let ([ThetaType -> TcM (InstInfo GhcPs)]
_, [BagDerivStuff]
deriv_stuff, [[Name]]
fvs) = [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> ([ThetaType -> TcM (InstInfo GhcPs)], [BagDerivStuff], [[Name]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall a. [a] -> [a] -> [a]
++ [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2)
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; let (Bag (LHsBind GhcPs, LSig GhcPs)
binds, Bag FamInst
famInsts) = DynFlags
-> SrcSpan
-> BagDerivStuff
-> (Bag (LHsBind GhcPs, LSig GhcPs), Bag FamInst)
genAuxBinds DynFlags
dflags SrcSpan
loc
([BagDerivStuff] -> BagDerivStuff
forall a. [Bag a] -> Bag a
unionManyBags [BagDerivStuff]
deriv_stuff)
; let mk_inst_infos1 :: [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos1 = ((ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs))
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [ThetaType -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1
; [InstInfo GhcPs]
inst_infos1 <- [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos1 [DerivSpec ThetaType]
given_specs
; [FamInst]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv (Bag FamInst -> [FamInst]
forall a. Bag a -> [a]
bagToList Bag FamInst
famInsts) (TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn))
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a b. (a -> b) -> a -> b
$
do {
; [DerivSpec ThetaType]
final_specs <- [ClsInst] -> TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType]
forall a. [ClsInst] -> TcM a -> TcM a
extendLocalInstEnv ((InstInfo GhcPs -> ClsInst) -> [InstInfo GhcPs] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcPs -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec [InstInfo GhcPs]
inst_infos1) (TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType])
-> TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType]
forall a b. (a -> b) -> a -> b
$
[DerivSpec [ThetaOrigin]] -> TcM [DerivSpec ThetaType]
simplifyInstanceContexts [DerivSpec [ThetaOrigin]]
infer_specs
; let mk_inst_infos2 :: [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos2 = ((ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs))
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [ThetaType -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2
; [InstInfo GhcPs]
inst_infos2 <- [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos2 [DerivSpec ThetaType]
final_specs
; let inst_infos :: [InstInfo GhcPs]
inst_infos = [InstInfo GhcPs]
inst_infos1 [InstInfo GhcPs] -> [InstInfo GhcPs] -> [InstInfo GhcPs]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcPs]
inst_infos2
; (Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_binds, DefUses
rn_dus) <-
Bool
-> [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv Bool
is_boot [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
binds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag (InstInfo GhcRn) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (InstInfo GhcRn)
inst_info) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IO () -> TcRn ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_deriv String
"Derived instances"
(Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> Bag FamInst -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_info HsValBinds GhcRn
rn_binds Bag FamInst
famInsts))
; TcGblEnv
gbl_env <- [ClsInst]
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv ((InstInfo GhcRn -> ClsInst) -> [InstInfo GhcRn] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcRn -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_info))
TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let all_dus :: DefUses
all_dus = DefUses
rn_dus DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Name] -> Uses
NameSet.mkFVs ([Name] -> Uses) -> [Name] -> Uses
forall a b. (a -> b) -> a -> b
$ [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
fvs)
; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs TcGblEnv
gbl_env DefUses
all_dus, Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_binds) } }
where
ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
-> Bag FamInst
-> SDoc
ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> Bag FamInst -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_infos HsValBinds GhcRn
extra_binds Bag FamInst
repFamInsts
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Derived class instances:")
Int
2 ([SDoc] -> SDoc
vcat ((InstInfo GhcRn -> SDoc) -> [InstInfo GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcRn
i -> InstInfo GhcRn -> SDoc
forall (a :: Pass).
OutputableBndrId (GhcPass a) =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcRn
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"") (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_infos))
SDoc -> SDoc -> SDoc
$$ HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
extra_binds)
SDoc -> SDoc -> SDoc
$$ String -> SDoc -> SDoc
hangP String
"Derived type family instances:"
([SDoc] -> SDoc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
pprRepTy (Bag FamInst -> [FamInst]
forall a. Bag a -> [a]
bagToList Bag FamInst
repFamInsts)))
hangP :: String -> SDoc -> SDoc
hangP String
s SDoc
x = String -> SDoc
text String
"" SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang (PtrString -> SDoc
ptext (String -> PtrString
sLit String
s)) Int
2 SDoc
x
apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos = ((ThetaType -> TcM (InstInfo GhcPs))
-> DerivSpec ThetaType -> TcM (InstInfo GhcPs))
-> [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType]
-> TcM [InstInfo GhcPs]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\ThetaType -> TcM (InstInfo GhcPs)
f DerivSpec ThetaType
ds -> ThetaType -> TcM (InstInfo GhcPs)
f (DerivSpec ThetaType -> ThetaType
forall theta. DerivSpec theta -> theta
ds_theta DerivSpec ThetaType
ds))
pprRepTy :: FamInst -> SDoc
pprRepTy :: FamInst -> SDoc
pprRepTy fi :: FamInst
fi@(FamInst { fi_tys :: FamInst -> ThetaType
fi_tys = ThetaType
lhs })
= String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> ThetaType -> Type
mkTyConApp (FamInst -> TyCon
famInstTyCon FamInst
fi) ThetaType
lhs) SDoc -> SDoc -> SDoc
<+>
SDoc
equals SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs
where rhs :: Type
rhs = FamInst -> Type
famInstRHS FamInst
fi
renameDeriv :: Bool
-> [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: Bool
-> [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv Bool
is_boot [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
| Bool
is_boot
= do { ([InstInfo GhcRn]
rn_inst_infos, [Uses]
fvs) <- (InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> [InstInfo GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) ([InstInfo GhcRn], [Uses])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info [InstInfo GhcPs]
inst_infos
; (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [InstInfo GhcRn] -> Bag (InstInfo GhcRn)
forall a. [a] -> Bag a
listToBag [InstInfo GhcRn]
rn_inst_infos
, HsValBinds GhcRn
forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut, Uses -> DefUses
usesOnly ([Uses] -> Uses
plusFVs [Uses]
fvs)) }
| Bool
otherwise
= TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. TcRn a -> TcRn a
discardWarnings (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.EmptyCase (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.KindSignatures (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.TypeApplications (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM Extension
LangExt.RebindableSyntax (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"rnd" ([SDoc] -> SDoc
vcat ((InstInfo GhcPs -> SDoc) -> [InstInfo GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcPs
i -> InstInfo GhcPs -> SDoc
forall (a :: Pass).
OutputableBndrId (GhcPass a) =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"") [InstInfo GhcPs]
inst_infos))
; (Bag (LHsBind GhcPs)
aux_binds, Bag (LSig GhcPs)
aux_sigs) <- ((LHsBind GhcPs, LSig GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind GhcPs, LSig GhcPs))
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv) (Bag (LHsBind GhcPs), Bag (LSig GhcPs))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (b, c)) -> Bag a -> m (Bag b, Bag c)
mapAndUnzipBagM (LHsBind GhcPs, LSig GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind GhcPs, LSig GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
; let aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> Bag (LHsBind GhcPs) -> [LSig GhcPs] -> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds NoExt
XValBinds GhcPs GhcPs
noExt Bag (LHsBind GhcPs)
aux_binds (Bag (LSig GhcPs) -> [LSig GhcPs]
forall a. Bag a -> [a]
bagToList Bag (LSig GhcPs)
aux_sigs)
; HsValBindsLR GhcRn GhcPs
rn_aux_lhs <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
; let bndrs :: [IdP GhcRn]
bndrs = HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsValBinders HsValBindsLR GhcRn GhcPs
rn_aux_lhs
; (TcGblEnv, TcLclEnv)
envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn ((Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [IdP GhcRn]
[Name]
bndrs) MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv ;
; (TcGblEnv, TcLclEnv)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
envs (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
do { (HsValBinds GhcRn
rn_aux, DefUses
dus_aux) <- HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (Uses -> HsSigCtxt
TopSigCtxt ([Name] -> Uses
mkNameSet [IdP GhcRn]
[Name]
bndrs)) HsValBindsLR GhcRn GhcPs
rn_aux_lhs
; ([InstInfo GhcRn]
rn_inst_infos, [Uses]
fvs_insts) <- (InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> [InstInfo GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) ([InstInfo GhcRn], [Uses])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info [InstInfo GhcPs]
inst_infos
; (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstInfo GhcRn] -> Bag (InstInfo GhcRn)
forall a. [a] -> Bag a
listToBag [InstInfo GhcRn]
rn_inst_infos, HsValBinds GhcRn
rn_aux,
DefUses
dus_aux DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Uses] -> Uses
plusFVs [Uses]
fvs_insts)) } }
where
rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
rn_inst_info :: InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info
inst_info :: InstInfo GhcPs
inst_info@(InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
inst
, iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings
{ ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = Bag (LHsBind GhcPs)
binds
, ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
tyvars
, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig GhcPs]
sigs
, ib_extensions :: forall a. InstBindings a -> [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: forall a. InstBindings a -> Bool
ib_derived = Bool
sa } })
= ASSERT( null sigs )
[Name]
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall a. [Name] -> RnM (a, Uses) -> RnM (a, Uses)
bindLocalNamesFV [Name]
tyvars (IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall a b. (a -> b) -> a -> b
$
do { (LHsBinds GhcRn
rn_binds,[LSig GhcRn]
_, Uses
fvs) <- Bool
-> Name
-> [Name]
-> Bag (LHsBind GhcPs)
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], Uses)
rnMethodBinds Bool
False (ClsInst -> Name
is_cls_nm ClsInst
inst) [] Bag (LHsBind GhcPs)
binds []
; let binds' :: InstBindings GhcRn
binds' = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings { ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
rn_binds
, ib_tyvars :: [Name]
ib_tyvars = [Name]
tyvars
, ib_pragmas :: [LSig GhcRn]
ib_pragmas = []
, ib_extensions :: [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: Bool
ib_derived = Bool
sa }
; (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info { iBinds :: InstBindings GhcRn
iBinds = InstBindings GhcRn
binds' }, Uses
fvs) }
makeDerivSpecs :: Bool
-> [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs :: Bool -> [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs Bool
is_boot [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= do {
; [Maybe EarlyDerivSpec]
eqns1 <- [IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing)
(TyCon
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveClause TyCon
rep_tc ((LDerivStrategy GhcRn -> DerivStrategy GhcRn)
-> Maybe (LDerivStrategy GhcRn) -> Maybe (DerivStrategy GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LDerivStrategy GhcRn -> DerivStrategy GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (LDerivStrategy GhcRn)
dcs)
LHsSigType GhcRn
pred SDoc
err_ctxt)
| DerivInfo { di_rep_tc :: DerivInfo -> TyCon
di_rep_tc = TyCon
rep_tc, di_clauses :: DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
, di_ctxt :: DerivInfo -> SDoc
di_ctxt = SDoc
err_ctxt } <- [DerivInfo]
deriv_infos
, L SrcSpan
_ (HsDerivingClause { deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
dcs
, deriv_clause_tys :: forall pass. HsDerivingClause pass -> Located [LHsSigType pass]
deriv_clause_tys = L SrcSpan
_ [LHsSigType GhcRn]
preds })
<- [LHsDerivingClause GhcRn]
clauses
, LHsSigType GhcRn
pred <- [LHsSigType GhcRn]
preds
]
; [Maybe EarlyDerivSpec]
eqns2 <- (LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [LDerivDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> (LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone) [LDerivDecl GhcRn]
deriv_decls
; let eqns :: [EarlyDerivSpec]
eqns = [Maybe EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe EarlyDerivSpec]
eqns1 [Maybe EarlyDerivSpec]
-> [Maybe EarlyDerivSpec] -> [Maybe EarlyDerivSpec]
forall a. [a] -> [a] -> [a]
++ [Maybe EarlyDerivSpec]
eqns2)
; if Bool
is_boot then
do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([EarlyDerivSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EarlyDerivSpec]
eqns) (EarlyDerivSpec -> TcRn ()
add_deriv_err ([EarlyDerivSpec] -> EarlyDerivSpec
forall a. [a] -> a
head [EarlyDerivSpec]
eqns))
; [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
else [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return [EarlyDerivSpec]
eqns }
where
add_deriv_err :: EarlyDerivSpec -> TcRn ()
add_deriv_err EarlyDerivSpec
eqn
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (EarlyDerivSpec -> SrcSpan
earlyDSLoc EarlyDerivSpec
eqn) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Deriving not permitted in hs-boot file")
Int
2 (String -> SDoc
text String
"Use an instance declaration instead"))
deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn -> SDoc
-> TcM (Maybe EarlyDerivSpec)
deriveClause :: TyCon
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveClause TyCon
rep_tc Maybe (DerivStrategy GhcRn)
mb_strat LHsSigType GhcRn
pred SDoc
err_ctxt
= SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
[TyVar]
-> TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveTyData [TyVar]
tvs TyCon
tc ThetaType
tys Maybe (DerivStrategy GhcRn)
mb_strat LHsSigType GhcRn
pred
where
tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
(TyCon
tc, ThetaType
tys) = case TyCon -> Maybe (TyCon, ThetaType, CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
Just (TyCon
fam_tc, ThetaType
pats, CoAxiom Unbranched
_) -> (TyCon
fam_tc, ThetaType
pats)
Maybe (TyCon, ThetaType, CoAxiom Unbranched)
_ -> (TyCon
rep_tc, [TyVar] -> ThetaType
mkTyVarTys [TyVar]
tvs)
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
deriveStandalone :: LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone (L SrcSpan
loc (DerivDecl XCDerivDecl GhcRn
_ LHsSigWcType GhcRn
deriv_ty Maybe (LDerivStrategy GhcRn)
mbl_deriv_strat Maybe (Located OverlapMode)
overlap_mode))
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
deriv_ty) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving decl for" (LHsSigWcType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
deriv_ty)
; let mb_deriv_strat :: Maybe (DerivStrategy GhcRn)
mb_deriv_strat = (LDerivStrategy GhcRn -> DerivStrategy GhcRn)
-> Maybe (LDerivStrategy GhcRn) -> Maybe (DerivStrategy GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LDerivStrategy GhcRn -> DerivStrategy GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (LDerivStrategy GhcRn)
mbl_deriv_strat
ctxt :: UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
TcType.InstDeclCtxt Bool
True
; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [Maybe (DerivStrategy GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcRn)
mb_deriv_strat, LHsSigWcType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
deriv_ty]
; (Maybe (DerivStrategy GhcTc)
mb_deriv_strat', [TyVar]
tvs', (DerivContext
deriv_ctxt', Class
cls, ThetaType
inst_tys'))
<- Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(DerivContext, Class, ThetaType))
forall a.
Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], a)
-> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
tcDerivStrategy Maybe (DerivStrategy GhcRn)
mb_deriv_strat (TcM ([TyVar], (DerivContext, Class, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(DerivContext, Class, ThetaType)))
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(DerivContext, Class, ThetaType))
forall a b. (a -> b) -> a -> b
$ do
([TyVar]
tvs, DerivContext
deriv_ctxt, Class
cls, ThetaType
inst_tys)
<- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, ThetaType)
tcStandaloneDerivInstType UserTypeCtxt
ctxt LHsSigWcType GhcRn
deriv_ty
([TyVar], (DerivContext, Class, ThetaType))
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, (DerivContext
deriv_ctxt, Class
cls, ThetaType
inst_tys))
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
inst_tys')) SDoc
derivingNullaryErr
; let inst_ty' :: Type
inst_ty' = ThetaType -> Type
forall a. [a] -> a
last ThetaType
inst_tys'
; ([TyVar]
tvs, DerivContext
deriv_ctxt, ThetaType
inst_tys) <-
case Maybe (DerivStrategy GhcTc)
mb_deriv_strat' of
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
let via_kind :: Type
via_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind XViaStrategy GhcTc
Type
via_ty
inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
inst_ty'
mb_match :: Maybe TCvSubst
mb_match = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
inst_ty_kind Type
via_kind
Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
(Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr Class
cls Type
inst_ty_kind
XViaStrategy GhcTc
Type
via_ty Type
via_kind)
let Just TCvSubst
kind_subst = Maybe TCvSubst
mb_match
ki_subst_range :: VarSet
ki_subst_range = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> TCvSubst -> Bool
`notElemTCvSubst` TCvSubst
kind_subst
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
[TyVar]
tvs'
(TCvSubst
subst, [TyVar]
_) = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
(DerivContext
final_deriv_ctxt, ThetaType
final_deriv_ctxt_tys)
= case DerivContext
deriv_ctxt' of
InferContext Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
SupplyContext ThetaType
theta ->
let final_theta :: ThetaType
final_theta = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
subst ThetaType
theta
in (ThetaType -> DerivContext
SupplyContext ThetaType
final_theta, ThetaType
final_theta)
final_inst_tys :: ThetaType
final_inst_tys = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
inst_tys'
final_tvs :: [TyVar]
final_tvs = ThetaType -> [TyVar]
tyCoVarsOfTypesWellScoped (ThetaType -> [TyVar]) -> ThetaType -> [TyVar]
forall a b. (a -> b) -> a -> b
$
ThetaType
final_deriv_ctxt_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
final_inst_tys
([TyVar], DerivContext, ThetaType)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], DerivContext, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
final_tvs, DerivContext
final_deriv_ctxt, ThetaType
final_inst_tys)
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], DerivContext, ThetaType)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], DerivContext, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs', DerivContext
deriv_ctxt', ThetaType
inst_tys')
; let cls_tys :: ThetaType
cls_tys = Int -> ThetaType -> ThetaType
forall a. Int -> [a] -> [a]
take (ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
inst_tys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ThetaType
inst_tys
inst_ty :: Type
inst_ty = ThetaType -> Type
forall a. [a] -> a
last ThetaType
inst_tys
; String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving;" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tvs:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
, String -> SDoc
text String
"mb_deriv_strat:" SDoc -> SDoc -> SDoc
<+> Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
, String -> SDoc
text String
"deriv_ctxt:" SDoc -> SDoc -> SDoc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
deriv_ctxt
, String -> SDoc
text String
"cls:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
, String -> SDoc
text String
"tys:" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
inst_tys ]
; String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving:" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"class:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
, String -> SDoc
text String
"class types:" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
cls_tys
, String -> SDoc
text String
"type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty ]
; let bale_out :: SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
bale_out SDoc
msg = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a
failWithTc (Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
False Class
cls ThetaType
cls_tys
Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_deriv_strat' SDoc
msg)
; case HasCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe Type
inst_ty of
Just (TyCon
tc, ThetaType
tc_args)
| Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
-> do TcRn ()
warnUselessTypeable
Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
| Bool
otherwise
-> EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just (EarlyDerivSpec -> Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp ((Located OverlapMode -> OverlapMode)
-> Maybe (Located OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located OverlapMode -> OverlapMode
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (Located OverlapMode)
overlap_mode)
[TyVar]
tvs Class
cls ThetaType
cls_tys TyCon
tc ThetaType
tc_args
DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
Maybe (TyCon, ThetaType)
_ ->
SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
bale_out (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"The last argument of the instance must be a data or newtype application"
}
deriveStandalone (L SrcSpan
_ (XDerivDecl XXDerivDecl GhcRn
_)) = String -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. String -> a
panic String
"deriveStandalone"
tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType :: UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, ThetaType)
tcStandaloneDerivInstType UserTypeCtxt
ctxt
(HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
vars
, hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
deriv_ty_body })})
| ([LHsTyVarBndr GhcRn]
tvs, LHsContext GhcRn
theta, LHsType GhcRn
rho) <- LHsType GhcRn
-> ([LHsTyVarBndr GhcRn], LHsContext GhcRn, LHsType GhcRn)
forall pass.
LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy LHsType GhcRn
deriv_ty_body
, L SrcSpan
_ [LHsType GhcRn
wc_pred] <- LHsContext GhcRn
theta
, L SrcSpan
wc_span (HsWildCardTy XWildCardTy GhcRn
_) <- LHsType GhcRn -> LHsType GhcRn
forall pass. LHsType pass -> LHsType pass
ignoreParens LHsType GhcRn
wc_pred
= do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt (LHsSigType GhcRn -> TcM Type) -> LHsSigType GhcRn -> TcM Type
forall a b. (a -> b) -> a -> b
$
HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (LHsType GhcRn)
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
vars
, hsib_body :: LHsType GhcRn
hsib_body
= SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcRn
deriv_ty_body) (HsType GhcRn -> LHsType GhcRn) -> HsType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$
HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy { hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs
, hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExt
XForAllTy GhcRn
noExt
, hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
rho }}
let ([TyVar]
tvs, ThetaType
_theta, Class
cls, ThetaType
inst_tys) = Type -> ([TyVar], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
dfun_ty
([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, Maybe SrcSpan -> DerivContext
InferContext (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
wc_span), Class
cls, ThetaType
inst_tys)
| Bool
otherwise
= do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt LHsSigType GhcRn
deriv_ty
let ([TyVar]
tvs, ThetaType
theta, Class
cls, ThetaType
inst_tys) = Type -> ([TyVar], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
dfun_ty
([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, ThetaType -> DerivContext
SupplyContext ThetaType
theta, Class
cls, ThetaType
inst_tys)
tcStandaloneDerivInstType UserTypeCtxt
_ (HsWC XHsWC GhcRn (LHsSigType GhcRn)
_ (XHsImplicitBndrs XXHsImplicitBndrs GhcRn (LHsType GhcRn)
_))
= String -> TcM ([TyVar], DerivContext, Class, ThetaType)
forall a. String -> a
panic String
"tcStandaloneDerivInstType"
tcStandaloneDerivInstType UserTypeCtxt
_ (XHsWildCardBndrs XXHsWildCardBndrs GhcRn (LHsSigType GhcRn)
_)
= String -> TcM ([TyVar], DerivContext, Class, ThetaType)
forall a. String -> a
panic String
"tcStandaloneDerivInstType"
warnUselessTypeable :: TcM ()
warnUselessTypeable :: TcRn ()
warnUselessTypeable
= do { Bool
warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDerivingTypeable
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> SDoc -> TcRn ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDerivingTypeable)
(SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Deriving" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
typeableClassName) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"has no effect: all types now auto-derive Typeable" }
deriveTyData :: [TyVar] -> TyCon -> [Type]
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> TcM (Maybe EarlyDerivSpec)
deriveTyData :: [TyVar]
-> TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveTyData [TyVar]
tvs TyCon
tc ThetaType
tc_args Maybe (DerivStrategy GhcRn)
mb_deriv_strat LHsSigType GhcRn
deriv_pred
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall pass. LHsSigType pass -> LHsType pass
hsSigType LHsSigType GhcRn
deriv_pred)) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
do { (Maybe (DerivStrategy GhcTc)
mb_deriv_strat', [TyVar]
deriv_tvs, (Class
cls, ThetaType
cls_tys, ThetaType
cls_arg_kinds))
<- [TyVar]
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
tvs (TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType)))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
forall a b. (a -> b) -> a -> b
$
Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], (Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
forall a.
Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], a)
-> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
tcDerivStrategy Maybe (DerivStrategy GhcRn)
mb_deriv_strat (TcM ([TyVar], (Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType)))
-> TcM ([TyVar], (Class, ThetaType, ThetaType))
-> TcM
(Maybe (DerivStrategy GhcTc), [TyVar],
(Class, ThetaType, ThetaType))
forall a b. (a -> b) -> a -> b
$
LHsSigType GhcRn -> TcM ([TyVar], (Class, ThetaType, ThetaType))
tcHsDeriv LHsSigType GhcRn
deriv_pred
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ThetaType
cls_arg_kinds ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIsNot` Int
1) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (LHsSigType GhcRn -> SDoc
nonUnaryErr LHsSigType GhcRn
deriv_pred)
; let [Type
cls_arg_kind] = ThetaType
cls_arg_kinds
; if Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
then do TcRn ()
warnUselessTypeable
Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
else
do {
let (ThetaType
arg_kinds, Type
_) = Type -> (ThetaType, Type)
splitFunTys Type
cls_arg_kind
n_args_to_drop :: Int
n_args_to_drop = ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
arg_kinds
n_args_to_keep :: Int
n_args_to_keep = ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
tc_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args_to_drop
(ThetaType
tc_args_to_keep, ThetaType
args_to_drop)
= Int -> ThetaType -> (ThetaType, ThetaType)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_args_to_keep ThetaType
tc_args
inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args_to_keep)
mb_match :: Maybe TCvSubst
mb_match = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
inst_ty_kind Type
cls_arg_kind
enough_args :: Bool
enough_args = Int
n_args_to_keep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
; Bool -> SDoc -> TcRn ()
checkTc (Bool
enough_args Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
(TyCon -> Class -> ThetaType -> Type -> Bool -> SDoc
derivingKindErr TyCon
tc Class
cls ThetaType
cls_tys Type
cls_arg_kind Bool
enough_args)
; let propagate_subst :: TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs' ThetaType
cls_tys' ThetaType
tc_args'
= ([TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args)
where
ki_subst_range :: VarSet
ki_subst_range = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> TCvSubst -> Bool
`notElemTCvSubst` TCvSubst
kind_subst
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
[TyVar]
tkvs'
(TCvSubst
subst, [TyVar]
_) = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
final_tc_args :: ThetaType
final_tc_args = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
tc_args'
final_cls_tys :: ThetaType
final_cls_tys = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
cls_tys'
final_tkvs :: [TyVar]
final_tkvs = ThetaType -> [TyVar]
tyCoVarsOfTypesWellScoped (ThetaType -> [TyVar]) -> ThetaType -> [TyVar]
forall a b. (a -> b) -> a -> b
$
ThetaType
final_cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
final_tc_args
; let tkvs :: [TyVar]
tkvs = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ FV -> [TyVar]
fvVarList (FV -> [TyVar]) -> FV -> [TyVar]
forall a b. (a -> b) -> a -> b
$
FV -> FV -> FV
unionFV (ThetaType -> FV
tyCoFVsOfTypes ThetaType
tc_args_to_keep)
([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
Just TCvSubst
kind_subst = Maybe TCvSubst
mb_match
([TyVar]
tkvs', ThetaType
final_cls_tys', ThetaType
final_tc_args')
= TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs ThetaType
cls_tys ThetaType
tc_args_to_keep
; ([TyVar]
tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat) <-
case Maybe (DerivStrategy GhcTc)
mb_deriv_strat' of
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
let final_via_ty :: XViaStrategy GhcTc
final_via_ty = XViaStrategy GhcTc
via_ty
final_via_kind :: Type
final_via_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind XViaStrategy GhcTc
Type
final_via_ty
final_inst_ty_kind :: Type
final_inst_ty_kind
= HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
final_tc_args')
via_match :: Maybe TCvSubst
via_match = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
final_inst_ty_kind Type
final_via_kind
Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
via_match)
(Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr Class
cls Type
final_inst_ty_kind
XViaStrategy GhcTc
Type
final_via_ty Type
final_via_kind)
let Just TCvSubst
via_subst = Maybe TCvSubst
via_match
([TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args)
= TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst TCvSubst
via_subst [TyVar]
tkvs'
ThetaType
final_cls_tys' ThetaType
final_tc_args'
([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args
, DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc))
-> DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> a -> b
$ XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy (XViaStrategy GhcTc -> DerivStrategy GhcTc)
-> XViaStrategy GhcTc -> DerivStrategy GhcTc
forall a b. (a -> b) -> a -> b
$ HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
via_subst XViaStrategy GhcTc
Type
via_ty
)
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
tkvs', ThetaType
final_cls_tys', ThetaType
final_tc_args'
, Maybe (DerivStrategy GhcTc)
mb_deriv_strat' )
; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (deriving clause)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat, LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
deriv_pred]
; String -> SDoc -> TcRn ()
traceTc String
"derivTyData1" ([SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
pprTyVars [TyVar]
tvs, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
tc_args
, LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
deriv_pred
, [TyVar] -> SDoc
pprTyVars (ThetaType -> [TyVar]
tyCoVarsOfTypesList ThetaType
tc_args)
, Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args_to_keep, Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args_to_drop
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty_kind, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cls_arg_kind, Maybe TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe TCvSubst
mb_match
, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
final_tc_args, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
final_cls_tys ])
; String -> SDoc -> TcRn ()
traceTc String
"derivTyData2" ([SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tkvs ])
; let final_tc_app :: Type
final_tc_app = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
final_tc_args
; Bool -> SDoc -> TcRn ()
checkTc (VarSet -> ThetaType -> Bool
allDistinctTyVars ([TyVar] -> VarSet
mkVarSet [TyVar]
tkvs) ThetaType
args_to_drop)
(Class -> ThetaType -> Type -> SDoc
derivingEtaErr Class
cls ThetaType
final_cls_tys Type
final_tc_app)
; UserTypeCtxt -> Class -> ThetaType -> TcRn ()
checkValidInstHead UserTypeCtxt
DerivClauseCtxt Class
cls (ThetaType -> TcRn ()) -> ThetaType -> TcRn ()
forall a b. (a -> b) -> a -> b
$
ThetaType
final_cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
final_tc_app]
; EarlyDerivSpec
spec <- Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
forall a. Maybe a
Nothing [TyVar]
tkvs
Class
cls ThetaType
final_cls_tys TyCon
tc ThetaType
final_tc_args
(Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
forall a. Maybe a
Nothing) Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; String -> SDoc -> TcRn ()
traceTc String
"derivTyData" (EarlyDerivSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr EarlyDerivSpec
spec)
; Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$ EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just EarlyDerivSpec
spec } }
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> TyCon -> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> TcRn EarlyDerivSpec
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
overlap_mode [TyVar]
tvs Class
cls ThetaType
cls_tys TyCon
tycon ThetaType
tc_args DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
deriv_strat
= do {
FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let (TyCon
rep_tc, ThetaType
rep_tc_args, Coercion
_co) = FamInstEnvs -> TyCon -> ThetaType -> (TyCon, ThetaType, Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tycon ThetaType
tc_args
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc)
(SDoc -> TcRn ()
bale_out (String -> SDoc
text String
"No family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> ThetaType -> SDoc
pprTypeApp TyCon
tycon ThetaType
tc_args)))
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_boot (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
bale_out (String -> SDoc
text String
"Cannot derive instances in hs-boot files"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"Write an instance declaration instead")
; let deriv_env :: DerivEnv
deriv_env = DerivEnv :: Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> DerivEnv
DerivEnv
{ denv_overlap_mode :: Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: Class
denv_cls = Class
cls
, denv_cls_tys :: ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_tc :: TyCon
denv_tc = TyCon
tycon
, denv_tc_args :: ThetaType
denv_tc_args = ThetaType
tc_args
, denv_rep_tc :: TyCon
denv_rep_tc = TyCon
rep_tc
, denv_rep_tc_args :: ThetaType
denv_rep_tc_args = ThetaType
rep_tc_args
, denv_ctxt :: DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
deriv_strat }
; (ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec)
-> DerivEnv
-> ReaderT DerivEnv TcRn EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DerivEnv
deriv_env (ReaderT DerivEnv TcRn EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
if TyCon -> Bool
isNewTyCon TyCon
rep_tc then ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn else ReaderT DerivEnv TcRn EarlyDerivSpec
mkDataTypeEqn }
where
bale_out :: SDoc -> TcRn ()
bale_out SDoc
msg = SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
False Class
cls ThetaType
cls_tys
(TyCon -> ThetaType -> Type
mkTyConApp TyCon
tycon ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
deriv_strat SDoc
msg)
mkDataTypeEqn :: DerivM EarlyDerivSpec
mkDataTypeEqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mkDataTypeEqn
= do Maybe (DerivStrategy GhcTc)
mb_strat <- (DerivEnv -> Maybe (DerivStrategy GhcTc))
-> ReaderT DerivEnv TcRn (Maybe (DerivStrategy GhcTc))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat
let bale_out :: SDoc -> ReaderT DerivEnv TcRn b
bale_out SDoc
msg = do SDoc
err <- Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
False SDoc
msg
IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b)
-> IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall a b. (a -> b) -> a -> b
$ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcM a
failWithTc SDoc
err
case Maybe (DerivStrategy GhcTc)
mb_strat of
Just DerivStrategy GhcTc
StockStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out
Just DerivStrategy GhcTc
AnyclassStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out
Just (ViaStrategy XViaStrategy GhcTc
ty) -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via XViaStrategy GhcTc
Type
ty
Just DerivStrategy GhcTc
NewtypeStrategy -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out SDoc
gndNonNewtypeErr
Maybe (DerivStrategy GhcTc)
Nothing -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_mechanism DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out
mk_originative_eqn
:: DerivSpecMechanism
-> DerivM EarlyDerivSpec
mk_originative_eqn :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn DerivSpecMechanism
mechanism
= do DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tc
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let inst_ty :: Type
inst_ty = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args
inst_tys :: ThetaType
inst_tys = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]
DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
SrcSpan
loc <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn SrcSpan
getSrcSpanM
Name
dfun_name <- IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name)
-> IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall a b. (a -> b) -> a -> b
$ Class -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName' Class
cls TyCon
tc
case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wildcard ->
do { ([ThetaOrigin]
inferred_constraints, [TyVar]
tvs', ThetaType
inst_tys')
<- DerivSpecMechanism -> DerivM ([ThetaOrigin], [TyVar], ThetaType)
inferConstraints DerivSpecMechanism
mechanism
; EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec [ThetaOrigin] -> EarlyDerivSpec
InferTheta (DerivSpec [ThetaOrigin] -> EarlyDerivSpec)
-> DerivSpec [ThetaOrigin] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
DS
{ ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
, ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs'
, ds_cls :: Class
ds_cls = Class
cls, ds_tys :: ThetaType
ds_tys = ThetaType
inst_tys'
, ds_tc :: TyCon
ds_tc = TyCon
rep_tc
, ds_theta :: [ThetaOrigin]
ds_theta = [ThetaOrigin]
inferred_constraints
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism } }
SupplyContext ThetaType
theta ->
EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec ThetaType -> EarlyDerivSpec
GivenTheta (DerivSpec ThetaType -> EarlyDerivSpec)
-> DerivSpec ThetaType -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
DS
{ ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
, ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs
, ds_cls :: Class
ds_cls = Class
cls, ds_tys :: ThetaType
ds_tys = ThetaType
inst_tys
, ds_tc :: TyCon
ds_tc = TyCon
rep_tc
, ds_theta :: ThetaType
ds_theta = ThetaType
theta
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
forall a. Maybe a
Nothing
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism }
mk_coerce_based_eqn
:: (Type -> DerivSpecMechanism)
-> Type
-> DerivM EarlyDerivSpec
mk_coerce_based_eqn :: (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn Type -> DerivSpecMechanism
mk_mechanism Type
coerced_ty
= do DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tycon
, denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tycon
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Bool
sa_wildcard <- DerivM Bool
isStandaloneWildcardDeriv
let
rep_tys :: Type -> ThetaType
rep_tys Type
ty = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
ty]
rep_pred :: Type -> Type
rep_pred Type
ty = Class -> ThetaType -> Type
mkClassPred Class
cls (Type -> ThetaType
rep_tys Type
ty)
rep_pred_o :: Type -> PredOrigin
rep_pred_o Type
ty = CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin CtOrigin
deriv_origin TypeOrKind
TypeLevel (Type -> Type
rep_pred Type
ty)
sc_preds :: [PredOrigin]
cls_tyvars :: [TyVar]
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls
inst_ty :: Type
inst_ty = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tycon ThetaType
tc_args
inst_tys :: ThetaType
inst_tys = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]
sc_preds :: [PredOrigin]
sc_preds = (Type -> PredOrigin) -> ThetaType -> [PredOrigin]
forall a b. (a -> b) -> [a] -> [b]
map (CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin CtOrigin
deriv_origin TypeOrKind
TypeLevel) (ThetaType -> [PredOrigin]) -> ThetaType -> [PredOrigin]
forall a b. (a -> b) -> a -> b
$
HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta ([TyVar] -> ThetaType -> TCvSubst
HasDebugCallStack => [TyVar] -> ThetaType -> TCvSubst
zipTvSubst [TyVar]
cls_tyvars ThetaType
inst_tys) (ThetaType -> ThetaType) -> ThetaType -> ThetaType
forall a b. (a -> b) -> a -> b
$
Class -> ThetaType
classSCTheta Class
cls
deriv_origin :: CtOrigin
deriv_origin = Bool -> CtOrigin
mkDerivOrigin Bool
sa_wildcard
meth_preds :: Type -> [PredOrigin]
meths :: [TyVar]
meths = Class -> [TyVar]
classMethods Class
cls
meth_preds :: Type -> [PredOrigin]
meth_preds Type
ty
| [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
meths = []
| Bool
otherwise = Type -> PredOrigin
rep_pred_o Type
ty PredOrigin -> [PredOrigin] -> [PredOrigin]
forall a. a -> [a] -> [a]
: Type -> [PredOrigin]
coercible_constraints Type
ty
coercible_constraints :: Type -> [PredOrigin]
coercible_constraints Type
ty
= [ CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin (TyVar -> Type -> Type -> Bool -> CtOrigin
DerivOriginCoerce TyVar
meth Type
t1 Type
t2 Bool
sa_wildcard)
TypeOrKind
TypeLevel (Type -> Type -> Type
mkReprPrimEqPred Type
t1 Type
t2)
| TyVar
meth <- [TyVar]
meths
, let (Pair Type
t1 Type
t2) = Class -> [TyVar] -> ThetaType -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
tvs
ThetaType
inst_tys Type
ty TyVar
meth ]
all_thetas :: Type -> [ThetaOrigin]
all_thetas :: Type -> [ThetaOrigin]
all_thetas Type
ty = [[PredOrigin] -> ThetaOrigin
mkThetaOriginFromPreds ([PredOrigin] -> ThetaOrigin) -> [PredOrigin] -> ThetaOrigin
forall a b. (a -> b) -> a -> b
$ Type -> [PredOrigin]
meth_preds Type
ty [PredOrigin] -> [PredOrigin] -> [PredOrigin]
forall a. [a] -> [a] -> [a]
++ [PredOrigin]
sc_preds]
inferred_thetas :: [ThetaOrigin]
inferred_thetas = Type -> [ThetaOrigin]
all_thetas Type
coerced_ty
TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc String
"newtype deriving:" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> ThetaType
rep_tys Type
coerced_ty) SDoc -> SDoc -> SDoc
<+> [ThetaOrigin] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ThetaOrigin]
inferred_thetas
let mechanism :: DerivSpecMechanism
mechanism = Type -> DerivSpecMechanism
mk_mechanism Type
coerced_ty
bale_out :: SDoc -> DerivM ()
bale_out SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
Class -> (SDoc -> DerivM ()) -> DerivM ()
atf_coerce_based_error_checks Class
cls SDoc -> DerivM ()
bale_out
DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
Name
dfun_name <- IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name)
-> IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall a b. (a -> b) -> a -> b
$ Class -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName' Class
cls TyCon
tycon
SrcSpan
loc <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn SrcSpan
getSrcSpanM
case DerivContext
deriv_ctxt of
SupplyContext ThetaType
theta -> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec ThetaType -> EarlyDerivSpec
GivenTheta (DerivSpec ThetaType -> EarlyDerivSpec)
-> DerivSpec ThetaType -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
DS
{ ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
, ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs
, ds_cls :: Class
ds_cls = Class
cls, ds_tys :: ThetaType
ds_tys = ThetaType
inst_tys
, ds_tc :: TyCon
ds_tc = TyCon
rep_tycon
, ds_theta :: ThetaType
ds_theta = ThetaType
theta
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
forall a. Maybe a
Nothing
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism }
InferContext Maybe SrcSpan
wildcard -> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec [ThetaOrigin] -> EarlyDerivSpec
InferTheta (DerivSpec [ThetaOrigin] -> EarlyDerivSpec)
-> DerivSpec [ThetaOrigin] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
DS
{ ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
, ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs
, ds_cls :: Class
ds_cls = Class
cls, ds_tys :: ThetaType
ds_tys = ThetaType
inst_tys
, ds_tc :: TyCon
ds_tc = TyCon
rep_tycon
, ds_theta :: [ThetaOrigin]
ds_theta = [ThetaOrigin]
inferred_thetas
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism }
atf_coerce_based_error_checks
:: Class
-> (SDoc -> DerivM ())
-> DerivM ()
atf_coerce_based_error_checks :: Class -> (SDoc -> DerivM ()) -> DerivM ()
atf_coerce_based_error_checks Class
cls SDoc -> DerivM ()
bale_out
= let cls_tyvars :: [TyVar]
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls
ats_look_sensible :: Bool
ats_look_sensible
=
Bool
no_adfs
Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_without_last_cls_tv
Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_last_cls_tv_in_kinds
([TyCon]
adf_tcs, [TyCon]
atf_tcs) = (TyCon -> Bool) -> [TyCon] -> ([TyCon], [TyCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCon -> Bool
isDataFamilyTyCon [TyCon]
at_tcs
no_adfs :: Bool
no_adfs = [TyCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
adf_tcs
at_without_last_cls_tv :: Maybe TyCon
at_without_last_cls_tv
= (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> TyVar
last_cls_tv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TyCon -> [TyVar]
tyConTyVars TyCon
tc) [TyCon]
atf_tcs
at_last_cls_tv_in_kinds :: Maybe TyCon
at_last_cls_tv_in_kinds
= (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Bool
at_last_cls_tv_in_kind (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind)
(TyCon -> [TyVar]
tyConTyVars TyCon
tc)
Bool -> Bool -> Bool
|| Type -> Bool
at_last_cls_tv_in_kind (TyCon -> Type
tyConResKind TyCon
tc)) [TyCon]
atf_tcs
at_last_cls_tv_in_kind :: Type -> Bool
at_last_cls_tv_in_kind Type
kind
= TyVar
last_cls_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
kind
at_tcs :: [TyCon]
at_tcs = Class -> [TyCon]
classATs Class
cls
last_cls_tv :: TyVar
last_cls_tv = ASSERT( notNull cls_tyvars )
[TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
cls_tyvars
cant_derive_err :: SDoc
cant_derive_err
= [SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless Bool
no_adfs SDoc
adfs_msg
, SDoc -> (TyCon -> SDoc) -> Maybe TyCon -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty TyCon -> SDoc
at_without_last_cls_tv_msg
Maybe TyCon
at_without_last_cls_tv
, SDoc -> (TyCon -> SDoc) -> Maybe TyCon -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty TyCon -> SDoc
at_last_cls_tv_in_kinds_msg
Maybe TyCon
at_last_cls_tv_in_kinds
]
adfs_msg :: SDoc
adfs_msg = String -> SDoc
text String
"the class has associated data types"
at_without_last_cls_tv_msg :: TyCon -> SDoc
at_without_last_cls_tv_msg TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text String
"the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not parameterized over the last type variable")
Int
2 (String -> SDoc
text String
"of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))
at_last_cls_tv_in_kinds_msg :: TyCon -> SDoc
at_last_cls_tv_in_kinds_msg TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text String
"the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"contains the last type variable")
Int
2 (String -> SDoc
text String
"of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in a kind, which is not (yet) allowed")
in Bool -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ats_look_sensible (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> DerivM ()
bale_out SDoc
cant_derive_err
mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_stock :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
= do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tc
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
TyCon
tc TyCon
rep_tc of
CanDeriveStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ (SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn
StockClassError SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
OriginativeDerivStatus
_ -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Class -> SDoc
nonStdErr Class
cls)
mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_anyclass :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
= do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags -> Validity
canDeriveAnyClass DynFlags
dflags of
Validity
IsValid -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it DerivSpecMechanism
DerivSpecAnyClass
NotValid SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
mk_eqn_newtype :: Type
-> DerivM EarlyDerivSpec
mk_eqn_newtype :: Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype = (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn Type -> DerivSpecMechanism
DerivSpecNewtype
mk_eqn_via :: Type
-> DerivM EarlyDerivSpec
mk_eqn_via :: Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via = (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn Type -> DerivSpecMechanism
DerivSpecVia
mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_no_mechanism :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_mechanism DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
= do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tc
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let dac_error :: SDoc -> SDoc
dac_error SDoc
msg
| TyCon -> Bool
isClassTyCon TyCon
rep_tc
= SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a type class,"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and can only have a derived instance"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"if DeriveAnyClass is enabled"
| Bool
otherwise
= Class -> SDoc
nonStdErr Class
cls SDoc -> SDoc -> SDoc
$$ SDoc
msg
case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
TyCon
tc TyCon
rep_tc of
NonDerivableClass SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc -> SDoc
dac_error SDoc
msg)
StockClassError SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
CanDeriveStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ (SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn
OriginativeDerivStatus
CanDeriveAnyClass -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it DerivSpecMechanism
DerivSpecAnyClass
mkNewTypeEqn :: DerivM EarlyDerivSpec
mkNewTypeEqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn
= do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tycon
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tycon
, denv_rep_tc_args :: DerivEnv -> ThetaType
denv_rep_tc_args = ThetaType
rep_tc_args
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let newtype_deriving :: Bool
newtype_deriving = Extension -> DynFlags -> Bool
xopt Extension
LangExt.GeneralizedNewtypeDeriving DynFlags
dflags
deriveAnyClass :: Bool
deriveAnyClass = Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags
bale_out :: SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out = Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. Bool -> SDoc -> ReaderT DerivEnv TcRn b
bale_out' Bool
newtype_deriving
bale_out' :: Bool -> SDoc -> ReaderT DerivEnv TcRn b
bale_out' Bool
b SDoc
msg = do SDoc
err <- Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
b SDoc
msg
IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b)
-> IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall a b. (a -> b) -> a -> b
$ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcM a
failWithTc SDoc
err
non_std :: SDoc
non_std = Class -> SDoc
nonStdErr Class
cls
suggest_gnd :: SDoc
suggest_gnd = String -> SDoc
text String
"Try GeneralizedNewtypeDeriving for GHC's"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"newtype-deriving extension"
nt_eta_arity :: Int
nt_eta_arity = TyCon -> Int
newTyConEtadArity TyCon
rep_tycon
rep_inst_ty :: Type
rep_inst_ty = TyCon -> ThetaType -> Type
newTyConInstRhs TyCon
rep_tycon ThetaType
rep_tc_args
might_be_newtype_derivable :: Bool
might_be_newtype_derivable
= Bool -> Bool
not (Class -> Bool
non_coercible_class Class
cls)
Bool -> Bool -> Bool
&& Bool
eta_ok
eta_ok :: Bool
eta_ok = ThetaType
rep_tc_args ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
nt_eta_arity
cant_derive_err :: SDoc
cant_derive_err = Bool -> SDoc -> SDoc
ppUnless Bool
eta_ok SDoc
eta_msg
eta_msg :: SDoc
eta_msg = String -> SDoc
text String
"cannot eta-reduce the representation type enough"
MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
case Maybe (DerivStrategy GhcTc)
mb_strat of
Just DerivStrategy GhcTc
StockStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
Just DerivStrategy GhcTc
AnyclassStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
Just DerivStrategy GhcTc
NewtypeStrategy ->
if Bool
eta_ok Bool -> Bool -> Bool
&& Bool
newtype_deriving
then Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype Type
rep_inst_ty
else SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
cant_derive_err SDoc -> SDoc -> SDoc
$$
if Bool
newtype_deriving then SDoc
empty else SDoc
suggest_gnd)
Just (ViaStrategy XViaStrategy GhcTc
via_ty) ->
Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via XViaStrategy GhcTc
Type
via_ty
Maybe (DerivStrategy GhcTc)
Nothing
| Bool
might_be_newtype_derivable
Bool -> Bool -> Bool
&& ((Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriveAnyClass)
Bool -> Bool -> Bool
|| Class -> Bool
std_class_via_coercible Class
cls)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype Type
rep_inst_ty
| Bool
otherwise
-> case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
TyCon
tycon TyCon
rep_tycon of
StockClassError SDoc
msg
| Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool
newtype_deriving
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype Type
rep_inst_ty
| Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
newtype_deriving
-> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
suggest_gnd)
| Bool
otherwise
-> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
NonDerivableClass SDoc
_msg
| Bool
newtype_deriving -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
cant_derive_err
| Bool
otherwise -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
non_std SDoc -> SDoc -> SDoc
$$ SDoc
suggest_gnd)
OriginativeDerivStatus
CanDeriveAnyClass -> do
Bool -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool
deriveAnyClass) (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$
TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
[ String -> SDoc
text String
"Both DeriveAnyClass and"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"GeneralizedNewtypeDeriving are enabled"
, String -> SDoc
text String
"Defaulting to the DeriveAnyClass strategy"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for instantiating" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
, String -> SDoc
text String
"Use DerivingStrategies to pick"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"a different strategy"
]
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn DerivSpecMechanism
DerivSpecAnyClass
CanDeriveStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
(SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn
genInst :: DerivSpec theta
-> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst :: DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_tc :: forall theta. DerivSpec theta -> TyCon
ds_tc = TyCon
rep_tycon
, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism, ds_tys :: forall theta. DerivSpec theta -> ThetaType
ds_tys = ThetaType
tys
, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc
, ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard })
= do (Bag (LHsBind GhcPs)
meth_binds, BagDerivStuff
deriv_stuff, [Name]
unusedNames)
<- TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall a. TcRn a -> TcRn a
set_span_and_ctxt (TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall a b. (a -> b) -> a -> b
$
DerivSpecMechanism
-> SrcSpan
-> Class
-> TyCon
-> ThetaType
-> [TyVar]
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
genDerivStuff DerivSpecMechanism
mechanism SrcSpan
loc Class
clas TyCon
rep_tycon ThetaType
tys [TyVar]
tvs
let mk_inst_info :: ThetaType -> TcM (InstInfo GhcPs)
mk_inst_info ThetaType
theta = TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs)
forall a. TcRn a -> TcRn a
set_span_and_ctxt (TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs))
-> TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs)
forall a b. (a -> b) -> a -> b
$ do
ClsInst
inst_spec <- ThetaType -> DerivSpec theta -> TcM ClsInst
forall theta. ThetaType -> DerivSpec theta -> TcM ClsInst
newDerivClsInst ThetaType
theta DerivSpec theta
spec
Class
-> ClsInst
-> ThetaType
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
inst_spec ThetaType
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
String -> SDoc -> TcRn ()
traceTc String
"newder" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
inst_spec)
InstInfo GhcPs -> TcM (InstInfo GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs -> TcM (InstInfo GhcPs))
-> InstInfo GhcPs -> TcM (InstInfo GhcPs)
forall a b. (a -> b) -> a -> b
$ InstInfo :: forall a. ClsInst -> InstBindings a -> InstInfo a
InstInfo
{ iSpec :: ClsInst
iSpec = ClsInst
inst_spec
, iBinds :: InstBindings GhcPs
iBinds = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings
{ ib_binds :: Bag (LHsBind GhcPs)
ib_binds = Bag (LHsBind GhcPs)
meth_binds
, ib_tyvars :: [Name]
ib_tyvars = (TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
Var.varName [TyVar]
tvs
, ib_pragmas :: [LSig GhcPs]
ib_pragmas = []
, ib_extensions :: [Extension]
ib_extensions = [Extension]
extensions
, ib_derived :: Bool
ib_derived = Bool
True } }
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (ThetaType -> TcM (InstInfo GhcPs)
mk_inst_info, BagDerivStuff
deriv_stuff, [Name]
unusedNames)
where
extensions :: [LangExt.Extension]
extensions :: [Extension]
extensions
| DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism Bool -> Bool -> Bool
|| DerivSpecMechanism -> Bool
isDerivSpecVia DerivSpecMechanism
mechanism
= [Extension
LangExt.ImpredicativeTypes, Extension
LangExt.RankNTypes]
| Bool
otherwise
= []
set_span_and_ctxt :: TcM a -> TcM a
set_span_and_ctxt :: TcM a -> TcM a
set_span_and_ctxt = SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM a -> TcM a) -> (TcM a -> TcM a) -> TcM a -> TcM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Class -> ThetaType -> SDoc
instDeclCtxt3 Class
clas ThetaType
tys)
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism = do
DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc = TyCon
rep_tc } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Bool
standalone <- DerivM Bool
isStandaloneDeriv
let anyclass_strategy :: Bool
anyclass_strategy = DerivSpecMechanism -> Bool
isDerivSpecAnyClass DerivSpecMechanism
mechanism
via_strategy :: Bool
via_strategy = DerivSpecMechanism -> Bool
isDerivSpecVia DerivSpecMechanism
mechanism
bale_out :: SDoc -> DerivM ()
bale_out SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
GlobalRdrEnv
rdr_env <- IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> ReaderT DerivEnv TcRn GlobalRdrEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
let data_con_names :: [Name]
data_con_names = (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Name
dataConName (TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc)
hidden_data_cons :: Bool
hidden_data_cons = Bool -> Bool
not (Name -> Bool
isWiredInName (TyCon -> Name
tyConName TyCon
rep_tc)) Bool -> Bool -> Bool
&&
(TyCon -> Bool
isAbstractTyCon TyCon
rep_tc Bool -> Bool -> Bool
||
(Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
not_in_scope [Name]
data_con_names)
not_in_scope :: Name -> Bool
not_in_scope Name
dc = Maybe GlobalRdrElt -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc)
TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> TyCon -> TcRn ()
addUsedDataCons GlobalRdrEnv
rdr_env TyCon
rep_tc
Bool -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
anyclass_strategy Bool -> Bool -> Bool
|| Bool
via_strategy
Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
standalone Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
hidden_data_cons) (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$
SDoc -> DerivM ()
bale_out (SDoc -> DerivM ()) -> SDoc -> DerivM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
derivingHiddenErr TyCon
tc
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> ThetaType
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
clas_inst ThetaType
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
= do { String -> SDoc -> TcRn ()
traceTc String
"doDerivInstErrorChecks2" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
clas_inst)
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool
xpartial_sigs <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
wpartial_sigs <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
; case Maybe SrcSpan
wildcard of
Maybe SrcSpan
Nothing -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SrcSpan
span -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> SDoc -> TcRn ()
checkTc Bool
xpartial_sigs (SDoc -> Int -> SDoc -> SDoc
hang SDoc
partial_sig_msg Int
2 SDoc
pts_suggestion)
WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnPartialTypeSignatures)
Bool
wpartial_sigs SDoc
partial_sig_msg
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exotic_mechanism Bool -> Bool -> Bool
&& Class -> Name
className Class
clas Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
genericClassNames) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { Bool -> SDoc -> TcRn ()
failIfTc (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) SDoc
gen_inst_err
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (WarningMessages -> TcRn ()
recordUnsafeInfer WarningMessages
forall a. Bag a
emptyBag) } }
where
exotic_mechanism :: Bool
exotic_mechanism = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> Bool
isDerivSpecStock DerivSpecMechanism
mechanism
partial_sig_msg :: SDoc
partial_sig_msg = String -> SDoc
text String
"Found type wildcard" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char Char
'_')
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"standing for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ThetaType -> SDoc
pprTheta ThetaType
theta)
pts_suggestion :: SDoc
pts_suggestion
= String -> SDoc
text String
"To use the inferred type, enable PartialTypeSignatures"
gen_inst_err :: SDoc
gen_inst_err = String -> SDoc
text String
"Generic instances can only be derived in"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Safe Haskell using the stock strategy."
genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
-> TyCon -> [Type] -> [TyVar]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
genDerivStuff :: DerivSpecMechanism
-> SrcSpan
-> Class
-> TyCon
-> ThetaType
-> [TyVar]
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
genDerivStuff DerivSpecMechanism
mechanism SrcSpan
loc Class
clas TyCon
tycon ThetaType
inst_tys [TyVar]
tyvars
= case DerivSpecMechanism
mechanism of
DerivSpecNewtype Type
rhs_ty -> Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via Type
rhs_ty
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn SrcSpan
loc TyCon
tycon ThetaType
inst_tys
DerivSpecMechanism
DerivSpecAnyClass -> do
let mini_env :: VarEnv Type
mini_env = [(TyVar, Type)] -> VarEnv Type
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (Class -> [TyVar]
classTyVars Class
clas [TyVar] -> ThetaType -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ThetaType
inst_tys)
mini_subst :: TCvSubst
mini_subst = InScopeSet -> VarEnv Type -> TCvSubst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
tyvars)) VarEnv Type
mini_env
DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[[FamInst]]
tyfam_insts <-
ASSERT2( isValid (canDeriveAnyClass dflags)
, ppr "genDerivStuff: bad derived class" <+> ppr clas )
(ClassATItem -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [ClassATItem] -> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> TCvSubst
-> Uses
-> ClassATItem
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
tcATDefault SrcSpan
loc TCvSubst
mini_subst Uses
emptyNameSet)
(Class -> [ClassATItem]
classATItems Class
clas)
(Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bag (LHsBind GhcPs)
forall a. Bag a
emptyBag
, [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ((FamInst -> DerivStuff) -> [FamInst] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> DerivStuff
DerivFamInst ([[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tyfam_insts))
, [] )
DerivSpecVia Type
via_ty -> Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via Type
via_ty
where
gen_newtype_or_via :: Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via Type
ty = do
(Bag (LHsBind GhcPs)
binds, BagDerivStuff
faminsts) <- SrcSpan
-> Class
-> [TyVar]
-> ThetaType
-> Type
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff)
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars ThetaType
inst_tys Type
ty
(Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (LHsBind GhcPs)
binds, BagDerivStuff
faminsts, Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
unusedConName)
unusedConName :: Maybe Name
unusedConName :: Maybe Name
unusedConName
| DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism
= Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
forall a. NamedThing a => a -> Name
getName (DataCon -> Name) -> DataCon -> Name
forall a b. (a -> b) -> a -> b
$ [DataCon] -> DataCon
forall a. [a] -> a
head ([DataCon] -> DataCon) -> [DataCon] -> DataCon
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tycon
| Bool
otherwise
= Maybe Name
forall a. Maybe a
Nothing
nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr LHsSigType GhcRn
ct = SDoc -> SDoc
quotes (LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
ct)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a unary constraint, as expected by a deriving clause"
nonStdErr :: Class -> SDoc
nonStdErr :: Class -> SDoc
nonStdErr Class
cls =
SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a stock derivable class (Eq, Show, etc.)"
gndNonNewtypeErr :: SDoc
gndNonNewtypeErr :: SDoc
gndNonNewtypeErr =
String -> SDoc
text String
"GeneralizedNewtypeDeriving cannot be used on non-newtypes"
derivingNullaryErr :: MsgDoc
derivingNullaryErr :: SDoc
derivingNullaryErr = String -> SDoc
text String
"Cannot derive instances for nullary classes"
derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
derivingKindErr :: TyCon -> Class -> ThetaType -> Type -> Bool -> SDoc
derivingKindErr TyCon
tc Class
cls ThetaType
cls_tys Type
cls_kind Bool
enough_args
= [SDoc] -> SDoc
sep [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot derive well-kinded instance of form"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> ThetaType -> SDoc
pprClassPred Class
cls ThetaType
cls_tys
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"...")))
Int
2 SDoc
gen1_suggestion
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"expects an argument of kind"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind))
]
where
gen1_suggestion :: SDoc
gen1_suggestion | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
gen1ClassKey Bool -> Bool -> Bool
&& Bool
enough_args
= String -> SDoc
text String
"(Perhaps you intended to use PolyKinds)"
| Bool
otherwise = SDoc
Outputable.empty
derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc
derivingViaKindErr :: Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr Class
cls Type
cls_kind Type
via_ty Type
via_kind
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot derive instance via" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty))
Int
2 (String -> SDoc
text String
"Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"expects an argument of kind"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
via_kind))
derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
derivingEtaErr :: Class -> ThetaType -> Type -> SDoc
derivingEtaErr Class
cls ThetaType
cls_tys Type
inst_ty
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"Cannot eta-reduce to an instance of form",
Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"instance (...) =>"
SDoc -> SDoc -> SDoc
<+> Class -> ThetaType -> SDoc
pprClassPred Class
cls (ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]))]
derivingThingErr :: Bool -> Class -> [Type] -> Type
-> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
derivingThingErr :: Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
newtype_deriving Class
cls ThetaType
cls_tys Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_strat SDoc
why
= Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' Bool
newtype_deriving Class
cls ThetaType
cls_tys Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_strat
(SDoc
-> (DerivStrategy GhcTc -> SDoc)
-> Maybe (DerivStrategy GhcTc)
-> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty DerivStrategy GhcTc -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName Maybe (DerivStrategy GhcTc)
mb_strat) SDoc
why
derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
derivingThingErrM :: Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
newtype_deriving SDoc
why
= do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
SDoc -> DerivM SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> DerivM SDoc) -> SDoc -> DerivM SDoc
forall a b. (a -> b) -> a -> b
$ Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
newtype_deriving Class
cls ThetaType
cls_tys
(TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
mb_strat SDoc
why
derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
why
= do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc = TyCon
tc
, denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
SDoc -> DerivM SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> DerivM SDoc) -> SDoc -> DerivM SDoc
forall a b. (a -> b) -> a -> b
$ Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' (DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism) Class
cls ThetaType
cls_tys
(TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
mb_strat
(DerivStrategy GhcTc -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName (DerivStrategy GhcTc -> SDoc) -> DerivStrategy GhcTc -> SDoc
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> DerivStrategy GhcTc
derivSpecMechanismToStrategy DerivSpecMechanism
mechanism)
SDoc
why
derivingThingErr' :: Bool -> Class -> [Type] -> Type
-> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
derivingThingErr' :: Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' Bool
newtype_deriving Class
cls ThetaType
cls_tys Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_strat SDoc
strat_msg SDoc
why
= [SDoc] -> SDoc
sep [(SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Can't make a derived instance of")
Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred) SDoc -> SDoc -> SDoc
<+> SDoc
via_mechanism)
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 SDoc
extra) SDoc -> SDoc -> SDoc
<> SDoc
colon,
Int -> SDoc -> SDoc
nest Int
2 SDoc
why]
where
strat_used :: Bool
strat_used = Maybe (DerivStrategy GhcTc) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (DerivStrategy GhcTc)
mb_strat
extra :: SDoc
extra | Bool -> Bool
not Bool
strat_used, Bool
newtype_deriving
= String -> SDoc
text String
"(even with cunning GeneralizedNewtypeDeriving)"
| Bool
otherwise = SDoc
empty
pred :: Type
pred = Class -> ThetaType -> Type
mkClassPred Class
cls (ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty])
via_mechanism :: SDoc
via_mechanism | Bool
strat_used
= String -> SDoc
text String
"with the" SDoc -> SDoc -> SDoc
<+> SDoc
strat_msg SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"strategy"
| Bool
otherwise
= SDoc
empty
derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr TyCon
tc
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The data constructors of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"are not all in scope"))
Int
2 (String -> SDoc
text String
"so you cannot derive an instance for it")
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
ty = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the stand-alone deriving instance for")
Int
2 (SDoc -> SDoc
quotes (LHsSigWcType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
ty))