Commit 04b70cda authored by Iavor S. Diatchki's avatar Iavor S. Diatchki Committed by Ben Gamari

Add TemplateHaskell support for Overlapping pragmas

Reviewers: hvr, goldfire, austin, RyanGlScott, bgamari

Reviewed By: RyanGlScott, bgamari

Subscribers: RyanGlScott, thomie

Differential Revision: https://phabricator.haskell.org/D2118
parent 97f2b164
...@@ -429,7 +429,9 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl })) ...@@ -429,7 +429,9 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_tyfam_insts = ats , cid_sigs = prags, cid_tyfam_insts = ats
, cid_datafam_insts = adts }) , cid_datafam_insts = adts
, cid_overlap_mode = overlap
})
= addSimpleTyVarBinds tvs $ = addSimpleTyVarBinds tvs $
-- We must bring the type variables into scope, so their -- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't -- occurrences don't fail, even though the binders don't
...@@ -447,7 +449,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ...@@ -447,7 +449,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; ats1 <- mapM (repTyFamInstD . unLoc) ats ; ats1 <- mapM (repTyFamInstD . unLoc) ats
; adts1 <- mapM (repDataFamInstD . unLoc) adts ; adts1 <- mapM (repDataFamInstD . unLoc) adts
; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
; repInst cxt1 inst_ty1 decls } ; rOver <- repOverlap (fmap unLoc overlap)
; repInst rOver cxt1 inst_ty1 decls }
where where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
...@@ -1865,8 +1868,26 @@ repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] ...@@ -1865,8 +1868,26 @@ repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
repTySyn (MkC nm) (MkC tvs) (MkC rhs) repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs] = rep2 tySynDName [nm, tvs, rhs]
repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repInst :: Core (Maybe TH.Overlap) ->
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
[o, cxt, ty, ds]
repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
repOverlap mb =
case mb of
Nothing -> nothing
Just o ->
case o of
NoOverlap _ -> nothing
Overlappable _ -> just =<< dataCon overlappableDataConName
Overlapping _ -> just =<< dataCon overlappingDataConName
Overlaps _ -> just =<< dataCon overlapsDataConName
Incoherent _ -> just =<< dataCon incoherentDataConName
where
nothing = coreNothing overlapTyConName
just = coreJust overlapTyConName
repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-> Core [TH.FunDep] -> Core [TH.DecQ] -> Core [TH.FunDep] -> Core [TH.DecQ]
......
...@@ -252,7 +252,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) ...@@ -252,7 +252,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
Right def -> return def Right def -> return def
Left (_, msg) -> failWith msg Left (_, msg) -> failWith msg
cvtDec (InstanceD ctxt ty decs) cvtDec (InstanceD o ctxt ty decs)
= do { let doc = text "an instance declaration" = do { let doc = text "an instance declaration"
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
...@@ -264,7 +264,17 @@ cvtDec (InstanceD ctxt ty decs) ...@@ -264,7 +264,17 @@ cvtDec (InstanceD ctxt ty decs)
, cid_binds = binds' , cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs' , cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts' , cid_tyfam_insts = ats', cid_datafam_insts = adts'
, cid_overlap_mode = Nothing } } , cid_overlap_mode = fmap (L loc . overlap) o } }
where
overlap pragma =
case pragma of
TH.Overlaps -> Hs.Overlaps "OVERLAPS"
TH.Overlappable -> Hs.Overlappable "OVERLAPPABLE"
TH.Overlapping -> Hs.Overlapping "OVERLAPPING"
TH.Incoherent -> Hs.Incoherent "INCOHERENT"
cvtDec (ForeignD ford) cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford = do { ford' <- cvtForD ford
......
...@@ -64,7 +64,8 @@ templateHaskellNames = [ ...@@ -64,7 +64,8 @@ templateHaskellNames = [
bindSName, letSName, noBindSName, parSName, bindSName, letSName, noBindSName, parSName,
-- Dec -- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName, funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, classDName, instanceWithOverlapDName,
standaloneDerivDName, sigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragAnnDName, defaultSigDName, pragRuleDName, pragAnnDName, defaultSigDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
...@@ -73,6 +74,7 @@ templateHaskellNames = [ ...@@ -73,6 +74,7 @@ templateHaskellNames = [
roleAnnotDName, roleAnnotDName,
-- Cxt -- Cxt
cxtName, cxtName,
-- SourceUnpackedness -- SourceUnpackedness
noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName, noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
-- SourceStrictness -- SourceStrictness
...@@ -115,6 +117,9 @@ templateHaskellNames = [ ...@@ -115,6 +117,9 @@ templateHaskellNames = [
conLikeDataConName, funLikeDataConName, conLikeDataConName, funLikeDataConName,
-- Phases -- Phases
allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
-- Overlap
overlappableDataConName, overlappingDataConName, overlapsDataConName,
incoherentDataConName,
-- TExp -- TExp
tExpDataConName, tExpDataConName,
-- RuleBndr -- RuleBndr
...@@ -140,6 +145,7 @@ templateHaskellNames = [ ...@@ -140,6 +145,7 @@ templateHaskellNames = [
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
overlapTyConName,
-- Quasiquoting -- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName] quoteDecName, quoteTypeName, quoteExpName, quotePatName]
...@@ -168,7 +174,8 @@ liftClassName = thCls (fsLit "Lift") liftClassKey ...@@ -168,7 +174,8 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName, qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
predTyConName, tExpTyConName, injAnnTyConName, kindTyConName :: Name predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
overlapTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
...@@ -185,7 +192,7 @@ predTyConName = thTc (fsLit "Pred") predTyConKey ...@@ -185,7 +192,7 @@ predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
kindTyConName = thTc (fsLit "Kind") kindTyConKey kindTyConName = thTc (fsLit "Kind") kindTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName, returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
...@@ -315,7 +322,8 @@ parSName = libFun (fsLit "parS") parSIdKey ...@@ -315,7 +322,8 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ... -- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
standaloneDerivDName, defaultSigDName, standaloneDerivDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataInstDName, newtypeInstDName, tySynInstDName,
...@@ -327,7 +335,9 @@ dataDName = libFun (fsLit "dataD") dataDIdKey ...@@ -327,7 +335,9 @@ dataDName = libFun (fsLit "dataD") dataDIdKey
newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey classDName = libFun (fsLit "classD") classDIdKey
instanceDName = libFun (fsLit "instanceD") instanceDIdKey instanceWithOverlapDName
= libFun (fsLit "instanceWithOverlapD")
instanceWithOverlapDIdKey
standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
...@@ -537,6 +547,16 @@ allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey ...@@ -537,6 +547,16 @@ allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-- data Overlap = ...
overlappableDataConName,
overlappingDataConName,
overlapsDataConName,
incoherentDataConName :: Name
overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey
overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
{- ********************************************************************* {- *********************************************************************
* * * *
...@@ -566,7 +586,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, ...@@ -566,7 +586,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey :: Unique roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
overlapTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200 expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201 matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202 clauseTyConKey = mkPreludeTyConUnique 202
...@@ -600,6 +621,7 @@ roleTyConKey = mkPreludeTyConUnique 229 ...@@ -600,6 +621,7 @@ roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230 tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231 injAnnTyConKey = mkPreludeTyConUnique 231
kindTyConKey = mkPreludeTyConUnique 232 kindTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
{- ********************************************************************* {- *********************************************************************
* * * *
...@@ -631,6 +653,17 @@ beforePhaseDataConKey = mkPreludeDataConUnique 107 ...@@ -631,6 +653,17 @@ beforePhaseDataConKey = mkPreludeDataConUnique 107
tExpDataConKey :: Unique tExpDataConKey :: Unique
tExpDataConKey = mkPreludeDataConUnique 108 tExpDataConKey = mkPreludeDataConUnique 108
-- data Overlap = ..
overlappableDataConKey,
overlappingDataConKey,
overlapsDataConKey,
incoherentDataConKey :: Unique
overlappableDataConKey = mkPreludeDataConUnique 109
overlappingDataConKey = mkPreludeDataConUnique 110
overlapsDataConKey = mkPreludeDataConUnique 111
incoherentDataConKey = mkPreludeDataConUnique 112
{- ********************************************************************* {- *********************************************************************
* * * *
...@@ -770,7 +803,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 ...@@ -770,7 +803,8 @@ parSIdKey = mkPreludeMiscIdUnique 323
-- data Dec = ... -- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, classDIdKey, instanceWithOverlapDIdKey, sigDIdKey, forImpDIdKey,
pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey,
closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
...@@ -782,7 +816,7 @@ dataDIdKey = mkPreludeMiscIdUnique 332 ...@@ -782,7 +816,7 @@ dataDIdKey = mkPreludeMiscIdUnique 332
newtypeDIdKey = mkPreludeMiscIdUnique 333 newtypeDIdKey = mkPreludeMiscIdUnique 333
tySynDIdKey = mkPreludeMiscIdUnique 334 tySynDIdKey = mkPreludeMiscIdUnique 334
classDIdKey = mkPreludeMiscIdUnique 335 classDIdKey = mkPreludeMiscIdUnique 335
instanceDIdKey = mkPreludeMiscIdUnique 336 instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 336
sigDIdKey = mkPreludeMiscIdUnique 337 sigDIdKey = mkPreludeMiscIdUnique 337
forImpDIdKey = mkPreludeMiscIdUnique 338 forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339 pragInlDIdKey = mkPreludeMiscIdUnique 339
......
...@@ -1543,11 +1543,17 @@ reifyClassInstance is_poly_tvs i ...@@ -1543,11 +1543,17 @@ reifyClassInstance is_poly_tvs i
; thtypes <- reifyTypes vis_types ; thtypes <- reifyTypes vis_types
; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
; return $ (TH.InstanceD cxt head_ty []) } ; return $ (TH.InstanceD over cxt head_ty []) }
where where
(_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
cls_tc = classTyCon cls cls_tc = classTyCon cls
dfun = instanceDFunId i dfun = instanceDFunId i
over = case overlapMode (is_flag i) of
NoOverlap _ -> Nothing
Overlappable _ -> Just TH.Overlappable
Overlapping _ -> Just TH.Overlapping
Overlaps _ -> Just TH.Overlaps
Incoherent _ -> Just TH.Incoherent
------------------------------ ------------------------------
reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
......
...@@ -29,6 +29,7 @@ instance Binary TH.Stmt ...@@ -29,6 +29,7 @@ instance Binary TH.Stmt
instance Binary TH.Pat instance Binary TH.Pat
instance Binary TH.Exp instance Binary TH.Exp
instance Binary TH.Dec instance Binary TH.Dec
instance Binary TH.Overlap
instance Binary TH.Guard instance Binary TH.Guard
instance Binary TH.Body instance Binary TH.Body
instance Binary TH.Match instance Binary TH.Match
......
...@@ -142,7 +142,9 @@ module Language.Haskell.TH( ...@@ -142,7 +142,9 @@ module Language.Haskell.TH(
-- **** Data -- **** Data
valD, funD, tySynD, dataD, newtypeD, valD, funD, tySynD, dataD, newtypeD,
-- **** Class -- **** Class
classD, instanceD, sigD, standaloneDerivD, defaultSigD, classD, instanceD, instanceWithOverlapD, Overlap(..),
sigD, standaloneDerivD, defaultSigD,
-- **** Role annotations -- **** Role annotations
roleAnnotD, roleAnnotD,
-- **** Type Family / Data Family -- **** Type Family / Data Family
......
...@@ -369,12 +369,17 @@ classD ctxt cls tvs fds decs = ...@@ -369,12 +369,17 @@ classD ctxt cls tvs fds decs =
return $ ClassD ctxt1 cls tvs fds decs1 return $ ClassD ctxt1 cls tvs fds decs1
instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ctxt ty decs = instanceD = instanceWithOverlapD Nothing
instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceWithOverlapD o ctxt ty decs =
do do
ctxt1 <- ctxt ctxt1 <- ctxt
decs1 <- sequence decs decs1 <- sequence decs
ty1 <- ty ty1 <- ty
return $ InstanceD ctxt1 ty1 decs1 return $ InstanceD o ctxt1 ty1 decs1
sigD :: Name -> TypeQ -> DecQ sigD :: Name -> TypeQ -> DecQ
sigD fun ty = liftM (SigD fun) $ ty sigD fun ty = liftM (SigD fun) $ ty
......
...@@ -290,7 +290,8 @@ ppr_dec _ (NewtypeD ctxt t xs ksig c decs) ...@@ -290,7 +290,8 @@ ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
ppr_dec _ (ClassD ctxt c xs fds ds) ppr_dec _ (ClassD ctxt c xs fds ds)
= text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds $$ where_clause ds
ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i ppr_dec _ (InstanceD o ctxt i ds) =
text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
$$ where_clause ds $$ where_clause ds
ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t
ppr_dec _ (ForeignD f) = ppr f ppr_dec _ (ForeignD f) = ppr f
...@@ -339,6 +340,15 @@ ppr_dec _ (StandaloneDerivD cxt ty) ...@@ -339,6 +340,15 @@ ppr_dec _ (StandaloneDerivD cxt ty)
ppr_dec _ (DefaultSigD n ty) ppr_dec _ (DefaultSigD n ty)
= hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
ppr_overlap :: Overlap -> Doc
ppr_overlap o = text $
case o of
Overlaps -> "{-# OVERLAPS #-}"
Overlappable -> "{-# OVERLAPPABLE #-}"
Overlapping -> "{-# OVERLAPPING #-}"
Incoherent -> "{-# INCOHERENT #-}"
ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
ppr_data maybeInst ctxt t argsDoc ksig cs decs ppr_data maybeInst ctxt t argsDoc ksig cs decs
= sep [text "data" <+> maybeInst = sep [text "data" <+> maybeInst
......
...@@ -1510,8 +1510,9 @@ data Dec ...@@ -1510,8 +1510,9 @@ data Dec
| TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@
| ClassD Cxt Name [TyVarBndr] | ClassD Cxt Name [TyVarBndr]
[FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
| InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w] | InstanceD (Maybe Overlap) Cxt Type [Dec]
-- where ds }@ -- ^ @{ instance {\-\# OVERLAPS \#-\}
-- Show w => Show [w] where ds }@
| SigD Name Type -- ^ @{ length :: [a] -> Int }@ | SigD Name Type -- ^ @{ length :: [a] -> Int }@
| ForeignD Foreign -- ^ @{ foreign import ... } | ForeignD Foreign -- ^ @{ foreign import ... }
--{ foreign export ... }@ --{ foreign export ... }@
...@@ -1549,6 +1550,15 @@ data Dec ...@@ -1549,6 +1550,15 @@ data Dec
| DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
deriving( Show, Eq, Ord, Data, Typeable, Generic ) deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | Properties for overlapping instances.
data Overlap = Overlappable -- ^ May be overlapped by more specific instances
| Overlapping -- ^ May overlap a more general instance
| Overlaps -- ^ Both 'Overlapping' and 'Overlappable'
| Incoherent -- ^ Both 'Overlappable' and 'Overlappable', and
-- pick an arbitrary one if multiple choices are
-- avaialble.
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. -- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
-- By analogy with with "head" for type classes and type class instances as -- By analogy with with "head" for type classes and type class instances as
-- defined in /Type classes: an exploration of the design space/, the -- defined in /Type classes: an exploration of the design space/, the
......
...@@ -47,6 +47,8 @@ ...@@ -47,6 +47,8 @@
* TODO: document API changes and important bugfixes * TODO: document API changes and important bugfixes
* Add support for OVERLAP(S/PED/PING) pragmas on instances
## 2.10.0.0 *Mar 2015* ## 2.10.0.0 *Mar 2015*
......
[InstanceD [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.(,)) (VarT a_0))) [ValD (VarP GHC.Base.return) (NormalB (VarE GHC.Err.undefined)) [],ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]] [InstanceD Nothing [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.(,)) (VarT a_0))) [ValD (VarP GHC.Base.return) (NormalB (VarE GHC.Err.undefined)) [],ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]]
...@@ -11,6 +11,6 @@ mkSimpleClass name = do ...@@ -11,6 +11,6 @@ mkSimpleClass name = do
TyConI (DataD [] dname [] Nothing cs _) <- reify name TyConI (DataD [] dname [] Nothing cs _) <- reify name
((NormalC conname []):_) <- return cs ((NormalC conname []):_) <- return cs
ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
[Clause [] (NormalB (ConE conname)) []]]] [Clause [] (NormalB (ConE conname)) []]]]
...@@ -12,6 +12,6 @@ mkSimpleClass name = do ...@@ -12,6 +12,6 @@ mkSimpleClass name = do
TyConI (DataD [] dname [] Nothing cs _) <- reify name TyConI (DataD [] dname [] Nothing cs _) <- reify name
((NormalC conname []):_) <- return cs ((NormalC conname []):_) <- return cs
ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
[Clause [] (NormalB (ConE conname)) []]]] [Clause [] (NormalB (ConE conname)) []]]]
...@@ -9,8 +9,8 @@ class D (f :: * -> *) ...@@ -9,8 +9,8 @@ class D (f :: * -> *)
instance C ((,) Int) instance C ((,) Int)
$(do { ClassI _ [inst_dec] <- reify ''C $(do { ClassI _ [inst_dec] <- reify ''C
; let InstanceD cxt (AppT _ ty) _ = inst_dec ; let InstanceD o cxt (AppT _ ty) _ = inst_dec
; return [InstanceD cxt ; return [InstanceD o cxt
(foldl AppT (ConT ''D) [ty]) (foldl AppT (ConT ''D) [ty])
[] []
] }) ] })
......
...@@ -8,7 +8,7 @@ class C a where ...@@ -8,7 +8,7 @@ class C a where
mkC :: Name -> Q [Dec] mkC :: Name -> Q [Dec]
mkC n = return mkC n = return
[InstanceD [] (AppT (ConT ''C) (ConT n)) [InstanceD Nothing [] (AppT (ConT ''C) (ConT n))
[ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []], [ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []],
PragmaD (InlineP 'inlinable Inline FunLike AllPhases) PragmaD (InlineP 'inlinable Inline FunLike AllPhases)
] ]
......
...@@ -10,5 +10,5 @@ class C α where ...@@ -10,5 +10,5 @@ class C α where
type AT α type AT α
bang DecsQ bang DecsQ
bang = return [InstanceD [] (AppT (ConT ''C) (ConT ''Int)) bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
[TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]] [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]]
...@@ -10,6 +10,6 @@ class C a where ...@@ -10,6 +10,6 @@ class C a where
bang' :: DecsQ bang' :: DecsQ
bang' = return [ bang' = return [
InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [ InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
DataInstD [] ''D [ConT ''Int] Nothing [ DataInstD [] ''D [ConT ''Int] Nothing [
NormalC (mkName "T") []] []]] NormalC (mkName "T") []] []]]
[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []] [InstanceD Nothing [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
[SigD f_4 (ForallT [PlainTV y_2,PlainTV t_3] [AppT (AppT EqualityT (VarT y_2)) (AppT (AppT ArrowT (VarT t_3)) (VarT t_3))] (AppT (AppT ArrowT (VarT y_2)) (VarT t_3))),FunD f_4 [Clause [VarP x_5] (NormalB (VarE x_5)) []]] [SigD f_4 (ForallT [PlainTV y_2,PlainTV t_3] [AppT (AppT EqualityT (VarT y_2)) (AppT (AppT ArrowT (VarT t_3)) (VarT t_3))] (AppT (AppT ArrowT (VarT y_2)) (VarT t_3))),FunD f_4 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
module TH_overlaps where
import Language.Haskell.TH
class C1 a where c1 :: a
class C2 a where c2 :: a
class C3 a where c3 :: a
[d|
instance {-# OVERLAPPABLE #-} C1 [a] where c1 = []
instance C1 [Int] where c1 = [1]
instance C2 [a] where c2 = []
instance {-# OVERLAPPING #-} C2 [Int] where c2 = [1]
instance C3 [a] where c3 = []
instance {-# OVERLAPS #-} C3 [[a]] where c3 = [[]]
instance C3 [[Int]] where c3 = [[1]]
|]
test1 :: ([Char],[Int])
test1 = (c1,c1)
test2 :: ([Char],[Int])
test2 = (c2,c2)
test3 :: ([Char],[[Char]],[[Int]])
test3 = (c3,c3,c3)
...@@ -26,6 +26,8 @@ test('TH_repGuard', normal, compile, ['-v0']) ...@@ -26,6 +26,8 @@ test('TH_repGuard', normal, compile, ['-v0'])
test('TH_repGuardOutput', normal, compile_and_run, ['']) test('TH_repGuardOutput', normal, compile_and_run, [''])
test('TH_repPatSig', normal, compile_fail, ['']) test('TH_repPatSig', normal, compile_fail, [''])
test('TH_overlaps', normal, compile, ['-v0'])
test('TH_spliceE5', test('TH_spliceE5',
extra_clean(['TH_spliceE5_Lib.hi', 'TH_spliceE5_Lib.o']),