Commit 6290eead authored by Iavor S. Diatchki's avatar Iavor S. Diatchki

Overlapable pragmas for individual instances (#9242)

Programmers may provide a pragma immediately after the `instance` keyword
to control the overlap/incoherence behavior for individual instances.
For example:

    instance {-# OVERLAP #-} C a where ...

I chose this notation, rather than the other two outlined in the ticket
for these reasons:

   1. Having the pragma after the type looks odd, I think.
   2. Having the pragma after there `where` does not work for
       stand-alone derived instances

I have implemented 3 pragams:

   1. NO_OVERLAP
   2. OVERLAP
   3. INCOHERENT

These correspond directly to the internal modes currently supported by
GHC.  If a pragma is specified, it will be used no matter what flags are
turned on.   For example, putting `NO_OVERLAP` on an instance will mark
it as non-overlapping, even if `OVERLAPPIN_INSTANCES` is turned on for the
module.
parent 99827150
......@@ -216,7 +216,7 @@ cvtDec (InstanceD ctxt ty decs)
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) }
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
......
......@@ -941,6 +941,7 @@ data ClsInstDecl name
, cid_sigs :: [LSig name] -- User-supplied pragmatic info
, cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances
, cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
, cid_overlap_mode :: Maybe OverlapMode
}
deriving (Data, Typeable)
......@@ -1013,6 +1014,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd })
instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
| null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
= top_matter
......@@ -1024,7 +1026,19 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
pprLHsBindsForUser binds sigs ]
where
top_matter = ptext (sLit "instance") <+> ppr inst_ty
top_matter = ptext (sLit "instance") <+> ppOveralapPragma mbOverlap
<+> ppr inst_ty
ppOveralapPragma :: Maybe OverlapMode -> SDoc
ppOveralapPragma mb =
case mb of
Nothing -> empty
Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}")
Just OverlapOk -> ptext (sLit "{-# OVERLAP #-}")
Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}")
instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
......@@ -1052,12 +1066,14 @@ instDeclDataFamInsts inst_decls
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
data DerivDecl name = DerivDecl { deriv_type :: LHsType name
, deriv_overlap_mode :: Maybe OverlapMode
}
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty)
= hsep [ptext (sLit "deriving instance"), ppr ty]
ppr (DerivDecl ty o)
= hsep [ptext (sLit "deriving instance"), ppOveralapPragma o, ppr ty]
\end{code}
%************************************************************************
......
......@@ -527,6 +527,9 @@ data Token
| ITvect_scalar_prag
| ITnovect_prag
| ITminimal_prag
| ITno_overlap_prag -- instance overlap mode
| IToverlap_prag -- instance overlap mode
| ITincoherent_prag -- instance overlap mode
| ITctype
| ITdotdot -- reserved symbols
......@@ -2428,6 +2431,9 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
("vectorize", token ITvect_prag),
("novectorize", token ITnovect_prag),
("minimal", token ITminimal_prag),
("no_overlap", token ITno_overlap_prag),
("overlap", token IToverlap_prag),
("incoherent", token ITincoherent_prag),
("ctype", token ITctype)])
twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
......
......@@ -269,6 +269,9 @@ incorrect.
'{-# NOVECTORISE' { L _ ITnovect_prag }
'{-# MINIMAL' { L _ ITminimal_prag }
'{-# CTYPE' { L _ ITctype }
'{-# NO_OVERLAP' { L _ ITno_overlap_prag }
'{-# OVERLAP' { L _ IToverlap_prag }
'{-# INCOHERENT' { L _ ITincoherent_prag }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
......@@ -654,12 +657,13 @@ ty_decl :: { LTyClDecl RdrName }
{% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
{ let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in
let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds
: 'instance' overlap_pragma inst_type where_inst
{ let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in
let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) }
in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) }
-- type instance declarations
| 'type' 'instance' ty_fam_inst_eqn
......@@ -677,6 +681,13 @@ inst_decl :: { LInstDecl RdrName }
{% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4
(unLoc $5) (unLoc $6) (unLoc $7) }
overlap_pragma :: { Maybe OverlapMode }
: '{-# OVERLAP' '#-}' { Just OverlapOk }
| '{-# INCOHERENT' '#-}' { Just Incoherent }
| '{-# NO_OVERLAP' '#-}' { Just NoOverlap }
| {- empty -} { Nothing }
-- Closed type families
where_type_family :: { Located (FamilyInfo RdrName) }
......@@ -783,7 +794,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
: 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
: 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) }
-----------------------------------------------------------------------------
-- Role annotations
......
......@@ -445,12 +445,14 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
-- Used for both source and interface file decls
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
, cid_sigs = [], cid_tyfam_insts = []
, cid_overlap_mode = oflag
, cid_datafam_insts = [] }
, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
......@@ -493,6 +495,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
`plusFV` inst_fvs
; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
, cid_overlap_mode = oflag
, cid_datafam_insts = adts' },
all_fvs) } } }
-- We return the renamed associated data type declarations so
......@@ -637,11 +640,11 @@ extendTyVarEnvForMethodBinds ktv_names thing_inside
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
rnSrcDerivDecl (DerivDecl ty overlap)
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
; return (DerivDecl ty', fvs) }
; return (DerivDecl ty' overlap, fvs) }
standaloneDerivErr :: SDoc
standaloneDerivErr
......
......@@ -93,6 +93,7 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan
, ds_tys :: [Type]
, ds_tc :: TyCon
, ds_tc_args :: [Type]
, ds_overlap :: Maybe OverlapMode
, ds_newtype :: Bool }
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
......@@ -618,7 +619,7 @@ deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
-- Standalone deriving declarations
-- e.g. deriving instance Show a => Show (T a)
-- Rather like tcLocalInstDecl
deriveStandalone (L loc (DerivDecl deriv_ty))
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
= setSrcSpan loc $
addErrCtxt (standaloneCtxt deriv_ty) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
......@@ -647,7 +648,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
; mkPolyKindedTypeableEqn cls tc }
| isAlgTyCon tc -- All other classes
-> do { spec <- mkEqnHelp tvs cls cls_tys tc tc_args (Just theta)
-> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta)
; return [spec] }
_ -> -- Complain about functions, primitive types, etc,
......@@ -769,7 +770,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
-- newtype T a s = ... deriving( ST s )
-- newtype K a a = ... deriving( Monad )
; spec <- mkEqnHelp (univ_kvs' ++ univ_tvs')
; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs')
cls final_cls_tys tc final_tc_args Nothing
; return [spec] } }
......@@ -851,7 +852,8 @@ and occurrence sites.
\begin{code}
mkEqnHelp :: [TyVar]
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> TyCon -> [Type]
-> DerivContext -- Just => context supplied (standalone deriving)
......@@ -862,7 +864,7 @@ mkEqnHelp :: [TyVar]
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
mkEqnHelp tvs cls cls_tys tycon tc_args mtheta
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
| className cls `elem` oldTypeableClassNames
= do { dflags <- getDynFlags
; case checkOldTypeableConditions (dflags, tycon, tc_args) of
......@@ -898,10 +900,10 @@ mkEqnHelp tvs cls cls_tys tycon tc_args mtheta
; dflags <- getDynFlags
; if isDataTyCon rep_tc then
mkDataTypeEqn dflags tvs cls cls_tys
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
else
mkNewTypeEqn dflags tvs cls cls_tys
mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta }
where
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
......@@ -991,6 +993,7 @@ See Note [Eta reduction for data family axioms] in TcInstDcls.
\begin{code}
mkDataTypeEqn :: DynFlags
-> Maybe OverlapMode
-> [Var] -- Universally quantified type variables in the instance
-> Class -- Class for which we need to derive an instance
-> [Type] -- Other parameters to the class except the last
......@@ -1002,7 +1005,7 @@ mkDataTypeEqn :: DynFlags
-> DerivContext -- Context of the instance, for standalone deriving
-> TcRn EarlyDerivSpec -- Return 'Nothing' if error
mkDataTypeEqn dflags tvs cls cls_tys
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
= case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
-- NB: pass the *representation* tycon to checkSideConditions
......@@ -1010,13 +1013,13 @@ mkDataTypeEqn dflags tvs cls cls_tys
NonDerivableClass -> bale_out (nonStdErr cls)
DerivableClassError msg -> bale_out msg
where
go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
mk_data_eqn :: [TyVar] -> Class
mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
= do loc <- getSrcSpanM
dfun_name <- new_dfun_name cls tycon
case mtheta of
......@@ -1028,6 +1031,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = inferred_constraints
, ds_overlap = overlap_mode
, ds_newtype = False }
Just theta -> do -- Specified context
return $ GivenTheta $ DS
......@@ -1036,6 +1040,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = theta
, ds_overlap = overlap_mode
, ds_newtype = False }
where
inst_tys = [mkTyConApp tycon tc_args]
......@@ -1073,7 +1078,9 @@ mkOldTypeableEqn tvs cls tycon tc_args mtheta
DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = []
, ds_cls = cls, ds_tys = [mkTyConApp tycon []]
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
, ds_theta = mtheta `orElse` []
, ds_overlap = Nothing -- Or, Just NoOverlap?
, ds_newtype = False }) }
mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec]
-- We can arrive here from a 'deriving' clause
......@@ -1098,6 +1105,9 @@ mkPolyKindedTypeableEqn cls tc
-- so we must instantiate it appropiately
, ds_tc = tc, ds_tc_args = tc_args
, ds_theta = [] -- Context is empty for polykinded Typeable
, ds_overlap = Nothing
-- Perhaps this should be `Just NoOverlap`?
, ds_newtype = False } }
where
(kvs,tc_app_kind) = splitForAllTys (tyConKind tc)
......@@ -1545,11 +1555,11 @@ a context for the Data instances:
%************************************************************************
\begin{code}
mkNewTypeEqn :: DynFlags -> [Var] -> Class
mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class
-> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
-> DerivContext
-> TcRn EarlyDerivSpec
mkNewTypeEqn dflags tvs
mkNewTypeEqn dflags overlap_mode tvs
cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
| ASSERT( length cls_tys + 1 == classArity cls )
......@@ -1564,6 +1574,7 @@ mkNewTypeEqn dflags tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta
, ds_overlap = overlap_mode
, ds_newtype = True }
Nothing -> return $ InferTheta $ DS
{ ds_loc = loc
......@@ -1571,6 +1582,7 @@ mkNewTypeEqn dflags tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = all_preds
, ds_overlap = overlap_mode
, ds_newtype = True }
| otherwise
= case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
......@@ -1584,7 +1596,7 @@ mkNewTypeEqn dflags tvs
| otherwise -> bale_out non_std
where
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
non_std = nonStdErr cls
......@@ -2043,9 +2055,10 @@ genInst :: Bool -- True <=> standalone deriving
-> OverlapFlag
-> CommonAuxiliaries
-> DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst standalone_deriv oflag comauxs
genInst standalone_deriv default_oflag comauxs
spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
, ds_overlap = overlap_mode
, ds_name = name, ds_cls = clas, ds_loc = loc })
| is_newtype
= do { inst_spec <- mkInstance oflag theta spec
......@@ -2076,6 +2089,7 @@ genInst standalone_deriv oflag comauxs
, ib_standalone_deriving = standalone_deriv } }
; return ( inst_info, deriv_stuff, Nothing ) }
where
oflag = setOverlapModeMaybe default_oflag overlap_mode
rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
......
......@@ -506,6 +506,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst])
tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = overlap_mode
, cid_datafam_insts = adts }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
......@@ -567,7 +568,9 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
-- Dfun location is that of instance *header*
; overlap_flag <- getOverlapFlag
; overlap_flag <-
do defaultOverlapFlag <- getOverlapFlag
return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
; (subst, tyvars') <- tcInstSkolTyVars tyvars
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment