{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Hs
import GHC.Driver.Session
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Core.Predicate
import GHC.Tc.Deriv.Infer
import GHC.Tc.Deriv.Utils
import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead )
import GHC.Core.InstEnv
import GHC.Tc.Utils.Instantiate
import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
import GHC.Rename.Utils
import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Utils.Error
import GHC.Core.DataCon
import GHC.Data.Maybe
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Set as NameSet
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Utils.FV as 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 (partition, find)
data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
| GivenTheta (DerivSpec ThetaType)
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec [PredType]])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta DerivSpec [ThetaOrigin]
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec [PredType]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec [ThetaOrigin]]
is, [DerivSpec [PredType]]
gs) -> (DerivSpec [ThetaOrigin]
spec DerivSpec [ThetaOrigin]
-> [DerivSpec [ThetaOrigin]] -> [DerivSpec [ThetaOrigin]]
forall a. a -> [a] -> [a]
: [DerivSpec [ThetaOrigin]]
is, [DerivSpec [PredType]]
gs)
splitEarlyDerivSpec (GivenTheta DerivSpec [PredType]
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec [PredType]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec [ThetaOrigin]]
is, [DerivSpec [PredType]]
gs) -> ([DerivSpec [ThetaOrigin]]
is, DerivSpec [PredType]
spec DerivSpec [PredType]
-> [DerivSpec [PredType]] -> [DerivSpec [PredType]]
forall a. a -> [a] -> [a]
: [DerivSpec [PredType]]
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 [PredType]
spec) = DerivSpec [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec [PredType]
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(Given)"
data DerivInfo = DerivInfo { DerivInfo -> TyCon
di_rep_tc :: TyCon
, DerivInfo -> [(Name, TyVar)]
di_scoped_tvs :: ![(Name,TyVar)]
, DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses :: [LHsDerivingClause GhcRn]
, DerivInfo -> SDoc
di_ctxt :: SDoc
}
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 {
[EarlyDerivSpec]
early_specs <- [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
; String -> SDoc -> TcRn ()
traceTc String
"tcDeriving" ([EarlyDerivSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EarlyDerivSpec]
early_specs)
; let ([DerivSpec [ThetaOrigin]]
infer_specs, [DerivSpec [PredType]]
given_specs) = [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec [PredType]])
splitEarlyDerivSpec [EarlyDerivSpec]
early_specs
; [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 <- (DerivSpec [PredType]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec [PredType]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec [PredType]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec [PredType]]
given_specs
; [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2 <- (DerivSpec [ThetaOrigin]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec [ThetaOrigin]]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[([PredType] -> 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)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec [ThetaOrigin]]
infer_specs
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; let ([[PredType] -> TcM (InstInfo GhcPs)]
_, [BagDerivStuff]
deriv_stuff, [[Name]]
fvs) = [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> ([[PredType] -> TcM (InstInfo GhcPs)], [BagDerivStuff],
[[Name]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall a. [a] -> [a] -> [a]
++ [([PredType] -> 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 :: [[PredType] -> TcM (InstInfo GhcPs)]
mk_inst_infos1 = (([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> [PredType] -> TcM (InstInfo GhcPs))
-> [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [[PredType] -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> [PredType] -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1
; [InstInfo GhcPs]
inst_infos1 <- [[PredType] -> TcM (InstInfo GhcPs)]
-> [DerivSpec [PredType]] -> TcM [InstInfo GhcPs]
apply_inst_infos [[PredType] -> TcM (InstInfo GhcPs)]
mk_inst_infos1 [DerivSpec [PredType]]
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 [PredType]]
final_specs <- [ClsInst]
-> TcM [DerivSpec [PredType]] -> TcM [DerivSpec [PredType]]
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 [PredType]] -> TcM [DerivSpec [PredType]])
-> TcM [DerivSpec [PredType]] -> TcM [DerivSpec [PredType]]
forall a b. (a -> b) -> a -> b
$
[DerivSpec [ThetaOrigin]] -> TcM [DerivSpec [PredType]]
simplifyInstanceContexts [DerivSpec [ThetaOrigin]]
infer_specs
; let mk_inst_infos2 :: [[PredType] -> TcM (InstInfo GhcPs)]
mk_inst_infos2 = (([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> [PredType] -> TcM (InstInfo GhcPs))
-> [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [[PredType] -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> [PredType] -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2
; [InstInfo GhcPs]
inst_infos2 <- [[PredType] -> TcM (InstInfo GhcPs)]
-> [DerivSpec [PredType]] -> TcM [InstInfo GhcPs]
apply_inst_infos [[PredType] -> TcM (InstInfo GhcPs)]
mk_inst_infos2 [DerivSpec [PredType]]
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) <- [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [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 (Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_deriv String
"Derived instances"
DumpFormat
FormatHaskell
(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 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 :: [[PredType] -> TcM (InstInfo GhcPs)]
-> [DerivSpec [PredType]] -> TcM [InstInfo GhcPs]
apply_inst_infos = (([PredType] -> TcM (InstInfo GhcPs))
-> DerivSpec [PredType] -> TcM (InstInfo GhcPs))
-> [[PredType] -> TcM (InstInfo GhcPs)]
-> [DerivSpec [PredType]]
-> TcM [InstInfo GhcPs]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\[PredType] -> TcM (InstInfo GhcPs)
f DerivSpec [PredType]
ds -> [PredType] -> TcM (InstInfo GhcPs)
f (DerivSpec [PredType] -> [PredType]
forall theta. DerivSpec theta -> theta
ds_theta DerivSpec [PredType]
ds))
pprRepTy :: FamInst -> SDoc
pprRepTy :: FamInst -> SDoc
pprRepTy fi :: FamInst
fi@(FamInst { fi_tys :: FamInst -> [PredType]
fi_tys = [PredType]
lhs })
= String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [PredType] -> PredType
mkTyConApp (FamInst -> TyCon
famInstTyCon FamInst
fi) [PredType]
lhs) SDoc -> SDoc -> SDoc
<+>
SDoc
equals SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
rhs
where rhs :: PredType
rhs = FamInst -> PredType
famInstRHS FamInst
fi
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
= 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
$
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.TemplateHaskellQuotes (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 a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"") [InstInfo GhcPs]
inst_infos))
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds, Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs) <- ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs)))
-> Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag (GenLocated SrcSpanAnnA (Sig GhcPs)))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (b, c)) -> Bag a -> m (Bag b, Bag c)
mapAndUnzipBagM (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
; let aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds AnnSortKey
XValBinds GhcPs GhcPs
NoAnnSortKey Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
LHsBindsLR GhcPs GhcPs
aux_binds (Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs)
; ([Name]
bndrs, HsValBindsLR GhcRn GhcPs
rn_aux_lhs) <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
; [Name]
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs (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) <- Uses -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> Uses
mkNameSet [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 = LHsBindsLR GhcPs 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 } })
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
rn_binds, [GenLocated SrcSpanAnnA (Sig GhcRn)]
rn_sigs, Uses
fvs) <- Bool
-> Name
-> [Name]
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], Uses)
rnMethodBinds Bool
False (ClsInst -> Name
is_cls_nm ClsInst
inst)
[Name]
tyvars LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs
; let binds' :: InstBindings GhcRn
binds' = InstBindings { ib_binds :: LHsBinds GhcRn
ib_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
LHsBinds GhcRn
rn_binds
, ib_tyvars :: [Name]
ib_tyvars = [Name]
tyvars
, ib_pragmas :: [LSig GhcRn]
ib_pragmas = [GenLocated SrcSpanAnnA (Sig GhcRn)]
[LSig GhcRn]
rn_sigs
, 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 :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs :: [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= do { [[EarlyDerivSpec]]
eqns1 <- [TcM [EarlyDerivSpec]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[EarlyDerivSpec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
dcs (LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds LDerivClauseTys GhcRn
dct) SDoc
err_ctxt
| DerivInfo { di_rep_tc :: DerivInfo -> TyCon
di_rep_tc = TyCon
rep_tc
, di_scoped_tvs :: DerivInfo -> [(Name, TyVar)]
di_scoped_tvs = [(Name, TyVar)]
scoped_tvs
, 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 -> LDerivClauseTys pass
deriv_clause_tys = LDerivClauseTys GhcRn
dct })
<- [GenLocated SrcSpan (HsDerivingClause GhcRn)]
[LHsDerivingClause GhcRn]
clauses
]
; [Maybe EarlyDerivSpec]
eqns2 <- (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (DerivDecl 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))
-> (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone) [GenLocated SrcSpanAnnA (DerivDecl GhcRn)]
[LDerivDecl GhcRn]
deriv_decls
; [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ [[EarlyDerivSpec]] -> [EarlyDerivSpec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EarlyDerivSpec]]
eqns1 [EarlyDerivSpec] -> [EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [a] -> [a] -> [a]
++ [Maybe EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe EarlyDerivSpec]
eqns2 }
where
deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds (L SrcSpanAnnC
_ DerivClauseTys GhcRn
dct) = case DerivClauseTys GhcRn
dct of
DctSingle XDctSingle GhcRn
_ LHsSigType GhcRn
ty -> [LHsSigType GhcRn
ty]
DctMulti XDctMulti GhcRn
_ [LHsSigType GhcRn]
tys -> [LHsSigType GhcRn]
tys
deriveClause :: TyCon
-> [(Name, TcTyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn] -> SDoc
-> TcM [EarlyDerivSpec]
deriveClause :: TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat [LHsSigType GhcRn]
deriv_preds SDoc
err_ctxt
= SDoc -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcRn ()
traceTc String
"deriveClause" (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
"scoped_tvs" SDoc -> SDoc -> SDoc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
scoped_tvs
, String -> SDoc
text String
"tc" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tys" SDoc -> SDoc -> SDoc
<+> [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
tys
, String -> SDoc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
<+> Maybe (GenLocated SrcSpan (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat ]
[(Name, TyVar)] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
scoped_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
(Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
mb_lderiv_strat', [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
[TyVar] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> TcM [EarlyDerivSpec]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (TyCon
-> [PredType]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [PredType]
tys Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat' [TyVar]
via_tvs) [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
[LHsSigType GhcRn]
deriv_preds
where
tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
(TyCon
tc, [PredType]
tys) = case TyCon -> Maybe (TyCon, [PredType], CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
Just (TyCon
fam_tc, [PredType]
pats, CoAxiom Unbranched
_) -> (TyCon
fam_tc, [PredType]
pats)
Maybe (TyCon, [PredType], CoAxiom Unbranched)
_ -> (TyCon
rep_tc, [TyVar] -> [PredType]
mkTyVarTys [TyVar]
tvs)
derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
-> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
derivePred :: TyCon
-> [PredType]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [PredType]
tys Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat [TyVar]
via_tvs LHsSigType GhcRn
deriv_pred =
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))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType GhcRn)
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
String -> SDoc -> TcRn ()
traceTc String
"derivePred" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tc" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tys" SDoc -> SDoc -> SDoc
<+> [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
tys
, String -> SDoc
text String
"deriv_pred" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
deriv_pred
, String -> SDoc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
<+> Maybe (GenLocated SrcSpan (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat
, String -> SDoc
text String
"via_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs ]
([TyVar]
cls_tvs, Class
cls, [PredType]
cls_tys, [PredType]
cls_arg_kinds) <- LHsSigType GhcRn -> TcM ([TyVar], Class, [PredType], [PredType])
tcHsDeriv LHsSigType GhcRn
deriv_pred
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PredType]
cls_arg_kinds [PredType] -> 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 [PredType
cls_arg_kind] = [PredType]
cls_arg_kinds
mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated SrcSpan (DerivStrategy GhcTc) -> DerivStrategy GhcTc)
-> Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan (DerivStrategy GhcTc) -> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat
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 let deriv_tvs :: [TyVar]
deriv_tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs in
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
<$> TyCon
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [PredType]
-> PredType
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc [PredType]
tys Maybe (DerivStrategy GhcTc)
mb_deriv_strat
[TyVar]
deriv_tvs Class
cls [PredType]
cls_tys PredType
cls_arg_kind
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
deriveStandalone :: LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone (L SrcSpanAnnA
loc (DerivDecl XCDerivDecl GhcRn
_ LHsSigWcType GhcRn
deriv_ty Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat Maybe (XRec GhcRn OverlapMode)
overlap_mode))
= SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
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" (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
LHsSigWcType GhcRn
deriv_ty)
; let ctxt :: UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
GHC.Tc.Types.Origin.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 (GenLocated SrcSpan (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (GenLocated SrcSpan (DerivStrategy GhcRn))
Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat, HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
LHsSigWcType GhcRn
deriv_ty]
; (Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
mb_lderiv_strat, [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
; ([TyVar]
cls_tvs, DerivContext
deriv_ctxt, Class
cls, [PredType]
inst_tys)
<- [TyVar]
-> TcM ([TyVar], DerivContext, Class, [PredType])
-> TcM ([TyVar], DerivContext, Class, [PredType])
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM ([TyVar], DerivContext, Class, [PredType])
-> TcM ([TyVar], DerivContext, Class, [PredType]))
-> TcM ([TyVar], DerivContext, Class, [PredType])
-> TcM ([TyVar], DerivContext, Class, [PredType])
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [PredType])
tcStandaloneDerivInstType UserTypeCtxt
ctxt LHsSigWcType GhcRn
deriv_ty
; let mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated SrcSpan (DerivStrategy GhcTc) -> DerivStrategy GhcTc)
-> Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan (DerivStrategy GhcTc) -> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
mb_lderiv_strat
tvs :: [TyVar]
tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs
; ([TyVar]
tvs', DerivContext
deriv_ctxt', [PredType]
inst_tys', Maybe (DerivStrategy GhcTc)
mb_deriv_strat') <-
case Maybe (DerivStrategy GhcTc)
mb_deriv_strat of
Just (ViaStrategy XViaStrategy GhcTc
via_ty)
| Just PredType
inst_ty <- [PredType] -> Maybe PredType
forall a. [a] -> Maybe a
lastMaybe [PredType]
inst_tys
-> do
let via_kind :: PredType
via_kind = HasDebugCallStack => PredType -> PredType
PredType -> PredType
tcTypeKind PredType
XViaStrategy GhcTc
via_ty
inst_ty_kind :: PredType
inst_ty_kind = HasDebugCallStack => PredType -> PredType
PredType -> PredType
tcTypeKind PredType
inst_ty
mb_match :: Maybe TCvSubst
mb_match = PredType -> PredType -> Maybe TCvSubst
tcUnifyTy PredType
inst_ty_kind PredType
via_kind
Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
(Class -> PredType -> PredType -> PredType -> SDoc
derivingViaKindErr Class
cls PredType
inst_ty_kind
PredType
XViaStrategy GhcTc
via_ty PredType
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, [PredType]
final_deriv_ctxt_tys)
= case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
SupplyContext [PredType]
theta ->
let final_theta :: [PredType]
final_theta = HasCallStack => TCvSubst -> [PredType] -> [PredType]
TCvSubst -> [PredType] -> [PredType]
substTheta TCvSubst
subst [PredType]
theta
in ([PredType] -> DerivContext
SupplyContext [PredType]
final_theta, [PredType]
final_theta)
final_inst_tys :: [PredType]
final_inst_tys = HasCallStack => TCvSubst -> [PredType] -> [PredType]
TCvSubst -> [PredType] -> [PredType]
substTys TCvSubst
subst [PredType]
inst_tys
final_via_ty :: PredType
final_via_ty = HasCallStack => TCvSubst -> PredType -> PredType
TCvSubst -> PredType -> PredType
substTy TCvSubst
subst PredType
XViaStrategy GhcTc
via_ty
final_tvs :: [TyVar]
final_tvs = [PredType] -> [TyVar]
tyCoVarsOfTypesWellScoped ([PredType] -> [TyVar]) -> [PredType] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
[PredType]
final_deriv_ctxt_tys [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType]
final_inst_tys
[PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType
final_via_ty]
([TyVar], DerivContext, [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, [PredType], Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tvs, DerivContext
final_deriv_ctxt, [PredType]
final_inst_tys
, DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy PredType
XViaStrategy GhcTc
final_via_ty) )
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], DerivContext, [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, [PredType], Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, DerivContext
deriv_ctxt, [PredType]
inst_tys, Maybe (DerivStrategy GhcTc)
mb_deriv_strat)
; 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
"inst_tys':" SDoc -> SDoc -> SDoc
<+> [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
inst_tys' ]
; 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 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
-> [PredType]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp ((GenLocated SrcSpanAnnP OverlapMode -> OverlapMode)
-> Maybe (GenLocated SrcSpanAnnP OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP OverlapMode -> OverlapMode
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpanAnnP OverlapMode)
Maybe (XRec GhcRn OverlapMode)
overlap_mode)
[TyVar]
tvs' Class
cls [PredType]
inst_tys'
DerivContext
deriv_ctxt' Maybe (DerivStrategy GhcTc)
mb_deriv_strat' }
tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType :: UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [PredType])
tcStandaloneDerivInstType UserTypeCtxt
ctxt
(HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(L SrcSpanAnnA
loc (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
deriv_ty_body }))})
| (Maybe (LHsContext GhcRn)
theta, LHsType GhcRn
rho) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
deriv_ty_body
, [LHsType GhcRn
wc_pred] <- Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
theta
, L SrcSpanAnnA
wc_span (HsWildCardTy XWildCardTy GhcRn
_) <- LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcRn
wc_pred
= do PredType
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM PredType
tcHsClsInstType UserTypeCtxt
ctxt (LHsSigType GhcRn -> TcM PredType)
-> LHsSigType GhcRn -> TcM PredType
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$
HsSig { sig_ext :: XHsSig GhcRn
sig_ext = NoExtField
XHsSig GhcRn
noExtField
, sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
, sig_body :: LHsType GhcRn
sig_body = LHsType GhcRn
rho }
let ([TyVar]
tvs, [PredType]
_theta, Class
cls, [PredType]
inst_tys) = PredType -> ([TyVar], [PredType], Class, [PredType])
tcSplitDFunTy PredType
dfun_ty
([TyVar], DerivContext, Class, [PredType])
-> TcM ([TyVar], DerivContext, Class, [PredType])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, Maybe SrcSpan -> DerivContext
InferContext (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
wc_span)), Class
cls, [PredType]
inst_tys)
| Bool
otherwise
= do PredType
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM PredType
tcHsClsInstType UserTypeCtxt
ctxt LHsSigType GhcRn
deriv_ty
let ([TyVar]
tvs, [PredType]
theta, Class
cls, [PredType]
inst_tys) = PredType -> ([TyVar], [PredType], Class, [PredType])
tcSplitDFunTy PredType
dfun_ty
([TyVar], DerivContext, Class, [PredType])
-> TcM ([TyVar], DerivContext, Class, [PredType])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, [PredType] -> DerivContext
SupplyContext [PredType]
theta, Class
cls, [PredType]
inst_tys)
warnUselessTypeable :: TcM ()
warnUselessTypeable :: TcRn ()
warnUselessTypeable
= do { Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv 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 :: TyCon -> [Type]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [Type]
-> Kind
-> TcM EarlyDerivSpec
deriveTyData :: TyCon
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [PredType]
-> PredType
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc [PredType]
tc_args Maybe (DerivStrategy GhcTc)
mb_deriv_strat [TyVar]
deriv_tvs Class
cls [PredType]
cls_tys PredType
cls_arg_kind
= do {
let ([Scaled PredType]
arg_kinds, PredType
_) = PredType -> ([Scaled PredType], PredType)
splitFunTys PredType
cls_arg_kind
n_args_to_drop :: Int
n_args_to_drop = [Scaled PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled PredType]
arg_kinds
n_args_to_keep :: Int
n_args_to_keep = [PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PredType]
tc_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args_to_drop
([PredType]
tc_args_to_keep, [PredType]
args_to_drop)
= Int -> [PredType] -> ([PredType], [PredType])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_args_to_keep [PredType]
tc_args
inst_ty_kind :: PredType
inst_ty_kind = HasDebugCallStack => PredType -> PredType
PredType -> PredType
tcTypeKind (TyCon -> [PredType] -> PredType
mkTyConApp TyCon
tc [PredType]
tc_args_to_keep)
mb_match :: Maybe TCvSubst
mb_match = PredType -> PredType -> Maybe TCvSubst
tcUnifyTy PredType
inst_ty_kind PredType
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 -> [PredType] -> PredType -> Bool -> SDoc
derivingKindErr TyCon
tc Class
cls [PredType]
cls_tys PredType
cls_arg_kind Bool
enough_args)
; let
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [PredType]
deriv_strat_tys = (DerivStrategy GhcTc -> [PredType])
-> Maybe (DerivStrategy GhcTc) -> [PredType]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([PredType]
-> (XViaStrategy GhcTc -> [PredType])
-> DerivStrategy GhcTc
-> [PredType]
forall p (pass :: Pass) r.
(p ~ GhcPass pass) =>
r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
foldDerivStrategy [] (XViaStrategy GhcTc -> [XViaStrategy GhcTc] -> [XViaStrategy GhcTc]
forall a. a -> [a] -> [a]
:[]))
propagate_subst :: TCvSubst
-> [TyVar]
-> [PredType]
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs' [PredType]
cls_tys' [PredType]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
= ([TyVar]
final_tkvs, [PredType]
final_cls_tys, [PredType]
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat)
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 :: [PredType]
final_tc_args = HasCallStack => TCvSubst -> [PredType] -> [PredType]
TCvSubst -> [PredType] -> [PredType]
substTys TCvSubst
subst [PredType]
tc_args'
final_cls_tys :: [PredType]
final_cls_tys = HasCallStack => TCvSubst -> [PredType] -> [PredType]
TCvSubst -> [PredType] -> [PredType]
substTys TCvSubst
subst [PredType]
cls_tys'
final_mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasCallStack => TCvSubst -> PredType -> PredType
TCvSubst -> PredType -> PredType
substTy TCvSubst
subst))
Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
final_tkvs :: [TyVar]
final_tkvs = [PredType] -> [TyVar]
tyCoVarsOfTypesWellScoped ([PredType] -> [TyVar]) -> [PredType] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
[PredType]
final_cls_tys [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType]
final_tc_args
[PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ Maybe (DerivStrategy GhcTc) -> [PredType]
deriv_strat_tys Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; 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 ([PredType] -> FV
tyCoFVsOfTypes [PredType]
tc_args_to_keep)
([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
Just TCvSubst
kind_subst = Maybe TCvSubst
mb_match
([TyVar]
tkvs', [PredType]
cls_tys', [PredType]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
= TCvSubst
-> [TyVar]
-> [PredType]
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs [PredType]
cls_tys
[PredType]
tc_args_to_keep Maybe (DerivStrategy GhcTc)
mb_deriv_strat
; ([TyVar]
final_tkvs, [PredType]
final_cls_tys, [PredType]
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 via_kind :: PredType
via_kind = HasDebugCallStack => PredType -> PredType
PredType -> PredType
tcTypeKind PredType
XViaStrategy GhcTc
via_ty
inst_ty_kind :: PredType
inst_ty_kind
= HasDebugCallStack => PredType -> PredType
PredType -> PredType
tcTypeKind (TyCon -> [PredType] -> PredType
mkTyConApp TyCon
tc [PredType]
tc_args')
via_match :: Maybe TCvSubst
via_match = PredType -> PredType -> Maybe TCvSubst
tcUnifyTy PredType
inst_ty_kind PredType
via_kind
Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
via_match)
(Class -> PredType -> PredType -> PredType -> SDoc
derivingViaKindErr Class
cls PredType
inst_ty_kind PredType
XViaStrategy GhcTc
via_ty PredType
via_kind)
let Just TCvSubst
via_subst = Maybe TCvSubst
via_match
([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc)))
-> ([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
forall a b. (a -> b) -> a -> b
$ TCvSubst
-> [TyVar]
-> [PredType]
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
via_subst [TyVar]
tkvs' [PredType]
cls_tys'
[PredType]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [PredType], [PredType], Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tkvs', [PredType]
cls_tys', [PredType]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 1" (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, [TyVar] -> SDoc
pprTyVars [TyVar]
deriv_tvs, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
tc_args
, [TyVar] -> SDoc
pprTyVars ([PredType] -> [TyVar]
tyCoVarsOfTypesList [PredType]
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
, PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
inst_ty_kind, PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
cls_arg_kind, Maybe TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe TCvSubst
mb_match
, [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
final_tc_args, [PredType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PredType]
final_cls_tys ]
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
final_tkvs ]
; let final_tc_app :: PredType
final_tc_app = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
tc [PredType]
final_tc_args
final_cls_args :: [PredType]
final_cls_args = [PredType]
final_cls_tys [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType
final_tc_app]
; Bool -> SDoc -> TcRn ()
checkTc (VarSet -> [PredType] -> Bool
allDistinctTyVars ([TyVar] -> VarSet
mkVarSet [TyVar]
final_tkvs) [PredType]
args_to_drop)
(Class -> [PredType] -> PredType -> SDoc
derivingEtaErr Class
cls [PredType]
final_cls_tys PredType
final_tc_app)
; UserTypeCtxt -> Class -> [PredType] -> TcRn ()
checkValidInstHead UserTypeCtxt
DerivClauseCtxt Class
cls [PredType]
final_cls_args
; EarlyDerivSpec
spec <- Maybe OverlapMode
-> [TyVar]
-> Class
-> [PredType]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
forall a. Maybe a
Nothing [TyVar]
final_tkvs Class
cls [PredType]
final_cls_args
(Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
forall a. Maybe a
Nothing) Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 3" (EarlyDerivSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr EarlyDerivSpec
spec)
; EarlyDerivSpec -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return EarlyDerivSpec
spec }
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> TcRn EarlyDerivSpec
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class
-> [PredType]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
overlap_mode [TyVar]
tvs Class
cls [PredType]
cls_args DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
deriv_strat = do
Bool
is_boot <- TcRnIf TcGblEnv TcLclEnv 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")
ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn DerivEnv
deriv_env
where
deriv_env :: DerivEnv
deriv_env = 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_inst_tys :: [PredType]
denv_inst_tys = [PredType]
cls_args
, denv_ctxt :: DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
deriv_strat }
bale_out :: SDoc -> TcRn ()
bale_out SDoc
msg = SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Class
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
False Class
cls [PredType]
cls_args Maybe (DerivStrategy GhcTc)
deriv_strat SDoc
msg
mk_eqn :: DerivM EarlyDerivSpec
mk_eqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn = do
DerivEnv { denv_inst_tys :: DerivEnv -> [PredType]
denv_inst_tys = [PredType]
cls_args
, 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
case Maybe (DerivStrategy GhcTc)
mb_strat of
Just (StockStrategy XStockStrategy GhcTc
_) -> do
([PredType]
cls_tys, PredType
inst_ty) <- [PredType] -> DerivM ([PredType], PredType)
expectNonNullaryClsArgs [PredType]
cls_args
DerivInstTys
dit <- [PredType] -> PredType -> DerivM DerivInstTys
expectAlgTyConApp [PredType]
cls_tys PredType
inst_ty
DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit
Just (AnyclassStrategy XAnyClassStrategy GhcTc
_) -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
([PredType]
cls_tys, PredType
inst_ty) <- [PredType] -> DerivM ([PredType], PredType)
expectNonNullaryClsArgs [PredType]
cls_args
[PredType]
-> PredType -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via [PredType]
cls_tys PredType
inst_ty PredType
XViaStrategy GhcTc
via_ty
Just (NewtypeStrategy XNewtypeStrategy GhcTc
_) -> do
([PredType]
cls_tys, PredType
inst_ty) <- [PredType] -> DerivM ([PredType], PredType)
expectNonNullaryClsArgs [PredType]
cls_args
DerivInstTys
dit <- [PredType] -> PredType -> DerivM DerivInstTys
expectAlgTyConApp [PredType]
cls_tys PredType
inst_ty
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> ReaderT DerivEnv TcRn ()
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False SDoc
gndNonNewtypeErr
Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
True DerivInstTys
dit
Maybe (DerivStrategy GhcTc)
Nothing -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs :: [PredType] -> DerivM ([PredType], PredType)
expectNonNullaryClsArgs [PredType]
inst_tys =
DerivM ([PredType], PredType)
-> (([PredType], PredType) -> DerivM ([PredType], PredType))
-> Maybe ([PredType], PredType)
-> DerivM ([PredType], PredType)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> SDoc -> DerivM ([PredType], PredType)
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False SDoc
derivingNullaryErr) ([PredType], PredType) -> DerivM ([PredType], PredType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([PredType], PredType) -> DerivM ([PredType], PredType))
-> Maybe ([PredType], PredType) -> DerivM ([PredType], PredType)
forall a b. (a -> b) -> a -> b
$
[PredType] -> Maybe ([PredType], PredType)
forall a. [a] -> Maybe ([a], a)
snocView [PredType]
inst_tys
expectAlgTyConApp :: [Type]
-> Type
-> DerivM DerivInstTys
expectAlgTyConApp :: [PredType] -> PredType -> DerivM DerivInstTys
expectAlgTyConApp [PredType]
cls_tys PredType
inst_ty = do
FamInstEnvs
fam_envs <- TcRn FamInstEnvs -> ReaderT DerivEnv TcRn FamInstEnvs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn FamInstEnvs
tcGetFamInstEnvs
case FamInstEnvs -> [PredType] -> PredType -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [PredType]
cls_tys PredType
inst_ty of
Maybe DerivInstTys
Nothing -> Bool -> SDoc -> DerivM DerivInstTys
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False (SDoc -> DerivM DerivInstTys) -> SDoc -> DerivM DerivInstTys
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"The last argument of the instance must be a"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"data or newtype application"
Just DerivInstTys
dit -> do DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
DerivInstTys -> DerivM DerivInstTys
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit
expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
expectNonDataFamTyCon :: DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_tc_args :: DerivInstTys -> [PredType]
dit_tc_args = [PredType]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) =
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> ReaderT DerivEnv TcRn ()
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False (SDoc -> ReaderT DerivEnv TcRn ())
-> SDoc -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"No family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> [PredType] -> SDoc
pprTypeApp TyCon
tc [PredType]
tc_args)
mk_deriv_inst_tys_maybe :: FamInstEnvs
-> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe :: FamInstEnvs -> [PredType] -> PredType -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [PredType]
cls_tys PredType
inst_ty =
((TyCon, [PredType]) -> DerivInstTys)
-> Maybe (TyCon, [PredType]) -> Maybe DerivInstTys
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon, [PredType]) -> DerivInstTys
lookup (Maybe (TyCon, [PredType]) -> Maybe DerivInstTys)
-> Maybe (TyCon, [PredType]) -> Maybe DerivInstTys
forall a b. (a -> b) -> a -> b
$ HasCallStack => PredType -> Maybe (TyCon, [PredType])
PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
inst_ty
where
lookup :: (TyCon, [Type]) -> DerivInstTys
lookup :: (TyCon, [PredType]) -> DerivInstTys
lookup (TyCon
tc, [PredType]
tc_args) =
let (TyCon
rep_tc, [PredType]
rep_tc_args, Coercion
_co) = FamInstEnvs -> TyCon -> [PredType] -> (TyCon, [PredType], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [PredType]
tc_args
in DerivInstTys { dit_cls_tys :: [PredType]
dit_cls_tys = [PredType]
cls_tys
, dit_tc :: TyCon
dit_tc = TyCon
tc
, dit_tc_args :: [PredType]
dit_tc_args = [PredType]
tc_args
, dit_rep_tc :: TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: [PredType]
dit_rep_tc_args = [PredType]
rep_tc_args }
mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
mk_eqn_from_mechanism :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism 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_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [PredType]
denv_inst_tys = [PredType]
inst_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DerivSpecMechanism -> ReaderT DerivEnv TcRn ()
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
-> [PredType] -> SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName Class
cls [PredType]
inst_tys SrcSpan
loc
case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wildcard ->
do { ([ThetaOrigin]
inferred_constraints, [TyVar]
tvs', [PredType]
inst_tys')
<- DerivSpecMechanism -> DerivM ([ThetaOrigin], [TyVar], [PredType])
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
{ 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 :: [PredType]
ds_tys = [PredType]
inst_tys'
, 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 [PredType]
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 [PredType] -> EarlyDerivSpec
GivenTheta (DerivSpec [PredType] -> EarlyDerivSpec)
-> DerivSpec [PredType] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ 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 :: [PredType]
ds_tys = [PredType]
inst_tys
, ds_theta :: [PredType]
ds_theta = [PredType]
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_eqn_stock :: DerivInstTys
-> DerivM EarlyDerivSpec
mk_eqn_stock :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [PredType]
dit_cls_tys = [PredType]
cls_tys
, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc })
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, 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
-> [PredType]
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls [PredType]
cls_tys
TyCon
tc TyCon
rep_tc of
CanDeriveStock SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fn :: SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
dsm_stock_gen_fn = SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn }
StockClassError SDoc
msg -> Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False SDoc
msg
OriginativeDerivStatus
_ -> Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False (Class -> SDoc
nonStdErr Class
cls)
mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
= 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
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
NotValid SDoc
msg -> Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False SDoc
msg
mk_eqn_newtype :: DerivInstTys
-> Type
-> DerivM EarlyDerivSpec
mk_eqn_newtype :: DerivInstTys -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit PredType
rep_ty =
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpecNewtype { dsm_newtype_dit :: DerivInstTys
dsm_newtype_dit = DerivInstTys
dit
, dsm_newtype_rep_ty :: PredType
dsm_newtype_rep_ty = PredType
rep_ty }
mk_eqn_via :: [Type]
-> Type
-> Type
-> DerivM EarlyDerivSpec
mk_eqn_via :: [PredType]
-> PredType -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via [PredType]
cls_tys PredType
inst_ty PredType
via_ty =
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpecVia { dsm_via_cls_tys :: [PredType]
dsm_via_cls_tys = [PredType]
cls_tys
, dsm_via_inst_ty :: PredType
dsm_via_inst_ty = PredType
inst_ty
, dsm_via_ty :: PredType
dsm_via_ty = PredType
via_ty }
mk_eqn_no_strategy :: DerivM EarlyDerivSpec
mk_eqn_no_strategy :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy = do
DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [PredType]
denv_inst_tys = [PredType]
cls_args } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
FamInstEnvs
fam_envs <- TcRn FamInstEnvs -> ReaderT DerivEnv TcRn FamInstEnvs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn FamInstEnvs
tcGetFamInstEnvs
if | Just ([PredType]
cls_tys, PredType
inst_ty) <- [PredType] -> Maybe ([PredType], PredType)
forall a. [a] -> Maybe ([a], a)
snocView [PredType]
cls_args
, Just DerivInstTys
dit <- FamInstEnvs -> [PredType] -> PredType -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [PredType]
cls_tys PredType
inst_ty
-> if | TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)
-> Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
False DerivInstTys
dit
| Bool
otherwise
-> do
Maybe
(SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
-> ((SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
-> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Class
-> Maybe
(SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
hasStockDeriving Class
cls) (((SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
-> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ())
-> ((SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
-> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ \SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
_ ->
DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative DerivInstTys
dit
| Bool
otherwise
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
where
mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec
mk_eqn_originative :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [PredType]
dit_cls_tys = [PredType]
cls_tys
, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, 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
-> [PredType]
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls
[PredType]
cls_tys TyCon
tc TyCon
rep_tc of
NonDerivableClass SDoc
msg -> Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False (SDoc -> SDoc
dac_error SDoc
msg)
StockClassError SDoc
msg -> Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
False SDoc
msg
CanDeriveStock SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fn :: SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
dsm_stock_gen_fn = SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn }
OriginativeDerivStatus
CanDeriveAnyClass -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
mkNewTypeEqn :: Bool
-> DerivInstTys -> DerivM EarlyDerivSpec
mkNewTypeEqn :: Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
newtype_strat dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [PredType]
dit_cls_tys = [PredType]
cls_tys
, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tycon
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tycon
, dit_rep_tc_args :: DerivInstTys -> [PredType]
dit_rep_tc_args = [PredType]
rep_tc_args })
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, 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 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 a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
newtype_deriving
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 :: PredType
rep_inst_ty = TyCon -> [PredType] -> PredType
newTyConInstRhs TyCon
rep_tycon [PredType]
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 = [PredType]
rep_tc_args [PredType] -> 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) )
if Bool
newtype_strat
then
if Bool
eta_ok Bool -> Bool -> Bool
&& Bool
newtype_deriving
then DerivInstTys -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit PredType
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)
else
if 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)
then DerivInstTys -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit PredType
rep_inst_ty
else case DynFlags
-> DerivContext
-> Class
-> [PredType]
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls [PredType]
cls_tys
TyCon
tycon TyCon
rep_tycon of
StockClassError SDoc
msg
| Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool
newtype_deriving
-> DerivInstTys -> PredType -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit PredType
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 -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool
deriveAnyClass) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnDerivingDefaults (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcRn ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDerivingDefaults) (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_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
CanDeriveStock SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fn :: SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
dsm_stock_gen_fn = SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn }
genInst :: DerivSpec theta
-> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst :: forall theta.
DerivSpec theta
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_tys :: forall theta. DerivSpec theta -> [PredType]
ds_tys = [PredType]
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 (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
meth_binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
meth_sigs, BagDerivStuff
deriv_stuff, [Name]
unusedNames)
<- TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
forall a. TcRn a -> TcRn a
set_span_and_ctxt (TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
forall a b. (a -> b) -> a -> b
$
DerivSpecMechanism
-> SrcSpan
-> Class
-> [PredType]
-> [TyVar]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
genDerivStuff DerivSpecMechanism
mechanism SrcSpan
loc Class
clas [PredType]
tys [TyVar]
tvs
let mk_inst_info :: [PredType] -> TcM (InstInfo GhcPs)
mk_inst_info [PredType]
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 <- [PredType] -> DerivSpec theta -> TcM ClsInst
forall theta. [PredType] -> DerivSpec theta -> TcM ClsInst
newDerivClsInst [PredType]
theta DerivSpec theta
spec
Class
-> ClsInst
-> [PredType]
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
inst_spec [PredType]
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
{ iSpec :: ClsInst
iSpec = ClsInst
inst_spec
, iBinds :: InstBindings GhcPs
iBinds = InstBindings
{ ib_binds :: LHsBindsLR GhcPs GhcPs
ib_binds = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
LHsBindsLR GhcPs 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 = [GenLocated SrcSpanAnnA (Sig GhcPs)]
[LSig GhcPs]
meth_sigs
, ib_extensions :: [Extension]
ib_extensions = [Extension]
extensions
, ib_derived :: Bool
ib_derived = Bool
True } }
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
([PredType] -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredType] -> 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
, Extension
LangExt.InstanceSigs
]
| Bool
otherwise
= []
set_span_and_ctxt :: TcM a -> TcM a
set_span_and_ctxt :: forall a. TcRn a -> TcRn a
set_span_and_ctxt = SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn a -> TcRn a) -> (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Class -> [PredType] -> SDoc
instDeclCtxt3 Class
clas [PredType]
tys)
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 :: DerivSpecMechanism -> ReaderT DerivEnv TcRn ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism =
case DerivSpecMechanism
mechanism of
DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit}
-> DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check DerivInstTys
dit
DerivSpecNewtype{dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit = DerivInstTys
dit}
-> do ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check DerivInstTys
dit
DerivSpecAnyClass{}
-> () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DerivSpecVia{}
-> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
where
data_cons_in_scope_check :: DerivInstTys -> DerivM ()
data_cons_in_scope_check :: DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
Bool
standalone <- DerivM Bool
isStandaloneDeriv
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let bale_out :: SDoc -> ReaderT DerivEnv TcRn ()
bale_out SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv -> ReaderT DerivEnv TcRn GlobalRdrEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn 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 (TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn 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 () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> TyCon -> TcRn ()
addUsedDataCons GlobalRdrEnv
rdr_env TyCon
rep_tc
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
hidden_data_cons) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> ReaderT DerivEnv TcRn ()
bale_out (SDoc -> ReaderT DerivEnv TcRn ())
-> SDoc -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
derivingHiddenErr TyCon
tc
atf_coerce_based_error_checks :: DerivM ()
atf_coerce_based_error_checks :: ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks = do
Class
cls <- (DerivEnv -> Class) -> ReaderT DerivEnv TcRn Class
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks DerivEnv -> Class
denv_cls
let bale_out :: SDoc -> ReaderT DerivEnv TcRn ()
bale_out SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
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 (PredType -> Bool
at_last_cls_tv_in_kind (PredType -> Bool) -> (TyVar -> PredType) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> PredType
tyVarKind)
(TyCon -> [TyVar]
tyConTyVars TyCon
tc)
Bool -> Bool -> Bool
|| PredType -> Bool
at_last_cls_tv_in_kind (TyCon -> PredType
tyConResKind TyCon
tc)) [TyCon]
atf_tcs
at_last_cls_tv_in_kind :: PredType -> Bool
at_last_cls_tv_in_kind PredType
kind
= TyVar
last_cls_tv TyVar -> VarSet -> Bool
`elemVarSet` PredType -> VarSet
exactTyCoVarsOfType PredType
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")
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ats_look_sensible (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> ReaderT DerivEnv TcRn ()
bale_out SDoc
cant_derive_err
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> [PredType]
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
clas_inst [PredType]
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 -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
wpartial_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv 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 ([PredType] -> SDoc
pprTheta [PredType]
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."
derivingThingFailWith :: Bool
-> SDoc
-> DerivM a
derivingThingFailWith :: forall a. Bool -> SDoc -> DerivM a
derivingThingFailWith Bool
newtype_deriving SDoc
msg = do
SDoc
err <- Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
newtype_deriving SDoc
msg
TcRn a -> DerivM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn a -> DerivM a) -> TcRn a -> DerivM a
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn a
forall a. SDoc -> TcM a
failWithTc SDoc
err
genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
-> [Type] -> [TyVar]
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
genDerivStuff :: DerivSpecMechanism
-> SrcSpan
-> Class
-> [PredType]
-> [TyVar]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
genDerivStuff DerivSpecMechanism
mechanism SrcSpan
loc Class
clas [PredType]
inst_tys [TyVar]
tyvars
= case DerivSpecMechanism
mechanism of
DerivSpecNewtype { dsm_newtype_rep_ty :: DerivSpecMechanism -> PredType
dsm_newtype_rep_ty = PredType
rhs_ty}
-> PredType
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
gen_newtype_or_via PredType
rhs_ty
DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: DerivInstTys -> [PredType]
dit_rep_tc_args = [PredType]
rep_tc_args
}
, dsm_stock_gen_fn :: DerivSpecMechanism
-> SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
dsm_stock_gen_fn = SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn }
-> SrcSpan
-> TyCon
-> [PredType]
-> [PredType]
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
gen_fn SrcSpan
loc TyCon
rep_tc [PredType]
rep_tc_args [PredType]
inst_tys
DerivSpecMechanism
DerivSpecAnyClass -> do
let mini_env :: VarEnv PredType
mini_env = [(TyVar, PredType)] -> VarEnv PredType
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (Class -> [TyVar]
classTyVars Class
clas [TyVar] -> [PredType] -> [(TyVar, PredType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [PredType]
inst_tys)
mini_subst :: TCvSubst
mini_subst = InScopeSet -> VarEnv PredType -> TCvSubst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
tyvars)) VarEnv PredType
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 (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs 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{dsm_via_ty :: DerivSpecMechanism -> PredType
dsm_via_ty = PredType
via_ty}
-> PredType
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
gen_newtype_or_via PredType
via_ty
where
gen_newtype_or_via :: PredType
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
gen_newtype_or_via PredType
ty = do
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, BagDerivStuff
faminsts) <- SrcSpan
-> Class
-> [TyVar]
-> [PredType]
-> PredType
-> TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], BagDerivStuff)
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars [PredType]
inst_tys PredType
ty
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
-> TcM
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, BagDerivStuff
faminsts, [])
nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr LHsSigType GhcRn
ct = SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
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 :: SDoc
derivingNullaryErr :: SDoc
derivingNullaryErr = String -> SDoc
text String
"Cannot derive instances for nullary classes"
derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc
derivingKindErr :: TyCon -> Class -> [PredType] -> PredType -> Bool -> SDoc
derivingKindErr TyCon
tc Class
cls [PredType]
cls_tys PredType
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 -> [PredType] -> SDoc
pprClassPred Class
cls [PredType]
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 (PredType -> SDoc
pprKind PredType
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 -> SDoc
derivingViaKindErr :: Class -> PredType -> PredType -> PredType -> SDoc
derivingViaKindErr Class
cls PredType
cls_kind PredType
via_ty PredType
via_kind
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot derive instance via" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PredType -> SDoc
pprType PredType
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 (PredType -> SDoc
pprKind PredType
cls_kind) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PredType -> SDoc
pprType PredType
via_ty)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PredType -> SDoc
pprKind PredType
via_kind))
derivingEtaErr :: Class -> [Type] -> Type -> SDoc
derivingEtaErr :: Class -> [PredType] -> PredType -> SDoc
derivingEtaErr Class
cls [PredType]
cls_tys PredType
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 -> [PredType] -> SDoc
pprClassPred Class
cls ([PredType]
cls_tys [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType
inst_ty]))]
derivingThingErr :: Bool -> Class -> [Type]
-> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc
derivingThingErr :: Bool
-> Class
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
newtype_deriving Class
cls [PredType]
cls_args Maybe (DerivStrategy GhcTc)
mb_strat SDoc
why
= Bool
-> Class
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' Bool
newtype_deriving Class
cls [PredType]
cls_args 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 -> SDoc -> DerivM SDoc
derivingThingErrM :: Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
newtype_deriving SDoc
why
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [PredType]
denv_inst_tys = [PredType]
cls_args
, 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
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
newtype_deriving Class
cls [PredType]
cls_args Maybe (DerivStrategy GhcTc)
mb_strat SDoc
why
derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
why
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> [PredType]
denv_inst_tys = [PredType]
cls_args
, 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
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' (DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism) Class
cls [PredType]
cls_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]
-> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc
derivingThingErr' :: Bool
-> Class
-> [PredType]
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' Bool
newtype_deriving Class
cls [PredType]
cls_args 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 (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
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 :: PredType
pred = Class -> [PredType] -> PredType
mkClassPred Class
cls [PredType]
cls_args
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 (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
LHsSigWcType GhcRn
ty))