summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs29
-rw-r--r--compiler/hsSyn/Convert.hs14
-rw-r--r--compiler/prelude/THNames.hs50
-rw-r--r--compiler/typecheck/TcSplice.hs8
-rw-r--r--libraries/ghci/GHCi/TH/Binary.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH.hs4
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs9
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs12
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs14
-rw-r--r--libraries/template-haskell/changelog.md2
-rw-r--r--testsuite/tests/ghci/scripts/T4127.stdout2
-rw-r--r--testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs2
-rw-r--r--testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs2
-rw-r--r--testsuite/tests/th/T5452.hs4
-rw-r--r--testsuite/tests/th/T5700a.hs2
-rw-r--r--testsuite/tests/th/T5886a.hs2
-rw-r--r--testsuite/tests/th/T7532a.hs2
-rw-r--r--testsuite/tests/th/T8625.stdout2
-rw-r--r--testsuite/tests/th/TH_overlaps.hs29
-rw-r--r--testsuite/tests/th/all.T2
20 files changed, 162 insertions, 30 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7ed96b4848..8f925d3eb2 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -429,7 +429,9 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_tyfam_insts = ats
- , cid_datafam_insts = adts })
+ , cid_datafam_insts = adts
+ , cid_overlap_mode = overlap
+ })
= addSimpleTyVarBinds tvs $
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
@@ -447,7 +449,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; ats1 <- mapM (repTyFamInstD . unLoc) ats
; adts1 <- mapM (repDataFamInstD . unLoc) adts
; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
- ; repInst cxt1 inst_ty1 decls }
+ ; rOver <- repOverlap (fmap unLoc overlap)
+ ; repInst rOver cxt1 inst_ty1 decls }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
@@ -1865,8 +1868,26 @@ repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
-repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
-repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
+repInst :: Core (Maybe TH.Overlap) ->
+ 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]
-> Core [TH.FunDep] -> Core [TH.DecQ]
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 47bbfb99bf..520eb138d6 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -252,7 +252,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
Right def -> return def
Left (_, msg) -> failWith msg
-cvtDec (InstanceD ctxt ty decs)
+cvtDec (InstanceD o ctxt ty decs)
= do { let doc = text "an instance declaration"
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
@@ -264,7 +264,17 @@ cvtDec (InstanceD ctxt ty decs)
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, 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)
= do { ford' <- cvtForD ford
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 2b22288347..671fe490c8 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -64,7 +64,8 @@ templateHaskellNames = [
bindSName, letSName, noBindSName, parSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
- classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName,
+ classDName, instanceWithOverlapDName,
+ standaloneDerivDName, sigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragAnnDName, defaultSigDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -73,6 +74,7 @@ templateHaskellNames = [
roleAnnotDName,
-- Cxt
cxtName,
+
-- SourceUnpackedness
noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
-- SourceStrictness
@@ -115,6 +117,9 @@ templateHaskellNames = [
conLikeDataConName, funLikeDataConName,
-- Phases
allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
+ -- Overlap
+ overlappableDataConName, overlappingDataConName, overlapsDataConName,
+ incoherentDataConName,
-- TExp
tExpDataConName,
-- RuleBndr
@@ -140,6 +145,7 @@ templateHaskellNames = [
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
+ overlapTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -168,7 +174,8 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
- predTyConName, tExpTyConName, injAnnTyConName, kindTyConName :: Name
+ predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
+ overlapTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
@@ -185,7 +192,7 @@ predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
kindTyConName = thTc (fsLit "Kind") kindTyConKey
-
+overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
@@ -315,7 +322,8 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
- instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
+ instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
+ pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
standaloneDerivDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName,
@@ -327,7 +335,9 @@ dataDName = libFun (fsLit "dataD") dataDIdKey
newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
-instanceDName = libFun (fsLit "instanceD") instanceDIdKey
+instanceWithOverlapDName
+ = libFun (fsLit "instanceWithOverlapD")
+ instanceWithOverlapDIdKey
standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
@@ -537,6 +547,16 @@ allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
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,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
- roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey :: Unique
+ roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
+ overlapTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -600,6 +621,7 @@ roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
kindTyConKey = mkPreludeTyConUnique 232
+overlapTyConKey = mkPreludeTyConUnique 233
{- *********************************************************************
* *
@@ -631,6 +653,17 @@ beforePhaseDataConKey = mkPreludeDataConUnique 107
tExpDataConKey :: Unique
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
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
- classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
+ classDIdKey, instanceWithOverlapDIdKey, sigDIdKey, forImpDIdKey,
+ pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey,
closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
@@ -782,7 +816,7 @@ dataDIdKey = mkPreludeMiscIdUnique 332
newtypeDIdKey = mkPreludeMiscIdUnique 333
tySynDIdKey = mkPreludeMiscIdUnique 334
classDIdKey = mkPreludeMiscIdUnique 335
-instanceDIdKey = mkPreludeMiscIdUnique 336
+instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 336
sigDIdKey = mkPreludeMiscIdUnique 337
forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 6183c59125..5483d0d432 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1543,11 +1543,17 @@ reifyClassInstance is_poly_tvs i
; thtypes <- reifyTypes vis_types
; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types 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
(_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
cls_tc = classTyCon cls
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]
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 6183a3d26f..ab9b35525a 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -29,6 +29,7 @@ instance Binary TH.Stmt
instance Binary TH.Pat
instance Binary TH.Exp
instance Binary TH.Dec
+instance Binary TH.Overlap
instance Binary TH.Guard
instance Binary TH.Body
instance Binary TH.Match
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 2f750e32a7..3bca8eaeef 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -142,7 +142,9 @@ module Language.Haskell.TH(
-- **** Data
valD, funD, tySynD, dataD, newtypeD,
-- **** Class
- classD, instanceD, sigD, standaloneDerivD, defaultSigD,
+ classD, instanceD, instanceWithOverlapD, Overlap(..),
+ sigD, standaloneDerivD, defaultSigD,
+
-- **** Role annotations
roleAnnotD,
-- **** Type Family / Data Family
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 81ef1fcbb6..6971970524 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -369,12 +369,17 @@ classD ctxt cls tvs fds decs =
return $ ClassD ctxt1 cls tvs fds decs1
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
ctxt1 <- ctxt
decs1 <- sequence decs
ty1 <- ty
- return $ InstanceD ctxt1 ty1 decs1
+ return $ InstanceD o ctxt1 ty1 decs1
+
+
sigD :: Name -> TypeQ -> DecQ
sigD fun ty = liftM (SigD fun) $ ty
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 3f79920a0b..2a56620684 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -290,7 +290,8 @@ ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
ppr_dec _ (ClassD ctxt c xs fds ds)
= text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ 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
ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t
ppr_dec _ (ForeignD f) = ppr f
@@ -339,6 +340,15 @@ ppr_dec _ (StandaloneDerivD cxt ty)
ppr_dec _ (DefaultSigD n 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 maybeInst ctxt t argsDoc ksig cs decs
= sep [text "data" <+> maybeInst
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index ce3c9083b2..c8d9d75b4b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1510,8 +1510,9 @@ data Dec
| TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@
| ClassD Cxt Name [TyVarBndr]
[FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
- | InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w]
- -- where ds }@
+ | InstanceD (Maybe Overlap) Cxt Type [Dec]
+ -- ^ @{ instance {\-\# OVERLAPS \#-\}
+ -- Show w => Show [w] where ds }@
| SigD Name Type -- ^ @{ length :: [a] -> Int }@
| ForeignD Foreign -- ^ @{ foreign import ... }
--{ foreign export ... }@
@@ -1549,6 +1550,15 @@ data Dec
| DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
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'.
-- By analogy with with "head" for type classes and type class instances as
-- defined in /Type classes: an exploration of the design space/, the
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index c313c62d14..e746cb54fc 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -47,6 +47,8 @@
* TODO: document API changes and important bugfixes
+ * Add support for OVERLAP(S/PED/PING) pragmas on instances
+
## 2.10.0.0 *Mar 2015*
diff --git a/testsuite/tests/ghci/scripts/T4127.stdout b/testsuite/tests/ghci/scripts/T4127.stdout
index 6c639747e8..abb0373bf1 100644
--- a/testsuite/tests/ghci/scripts/T4127.stdout
+++ b/testsuite/tests/ghci/scripts/T4127.stdout
@@ -1 +1 @@
-[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)) []]]
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
index ec4f7c9bbf..2bcc5a8a84 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
@@ -11,6 +11,6 @@ mkSimpleClass name = do
TyConI (DataD [] dname [] Nothing cs _) <- reify name
((NormalC conname []):_) <- return cs
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)) []]]]
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
index af7e5cf5b1..1a483dabab 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
@@ -12,6 +12,6 @@ mkSimpleClass name = do
TyConI (DataD [] dname [] Nothing cs _) <- reify name
((NormalC conname []):_) <- return cs
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)) []]]]
diff --git a/testsuite/tests/th/T5452.hs b/testsuite/tests/th/T5452.hs
index b727df5a47..de6a1771f7 100644
--- a/testsuite/tests/th/T5452.hs
+++ b/testsuite/tests/th/T5452.hs
@@ -9,8 +9,8 @@ class D (f :: * -> *)
instance C ((,) Int)
$(do { ClassI _ [inst_dec] <- reify ''C
- ; let InstanceD cxt (AppT _ ty) _ = inst_dec
- ; return [InstanceD cxt
+ ; let InstanceD o cxt (AppT _ ty) _ = inst_dec
+ ; return [InstanceD o cxt
(foldl AppT (ConT ''D) [ty])
[]
] })
diff --git a/testsuite/tests/th/T5700a.hs b/testsuite/tests/th/T5700a.hs
index 31dbfa9120..39d39b16a1 100644
--- a/testsuite/tests/th/T5700a.hs
+++ b/testsuite/tests/th/T5700a.hs
@@ -8,7 +8,7 @@ class C a where
mkC :: Name -> Q [Dec]
mkC n = return
- [InstanceD [] (AppT (ConT ''C) (ConT n))
+ [InstanceD Nothing [] (AppT (ConT ''C) (ConT n))
[ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []],
PragmaD (InlineP 'inlinable Inline FunLike AllPhases)
]
diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs
index 4d2cec6207..95aefc2792 100644
--- a/testsuite/tests/th/T5886a.hs
+++ b/testsuite/tests/th/T5886a.hs
@@ -10,5 +10,5 @@ class C α where
type AT α ∷ ★
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))]]
diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs
index 901e27a1bf..84fa23e69f 100644
--- a/testsuite/tests/th/T7532a.hs
+++ b/testsuite/tests/th/T7532a.hs
@@ -10,6 +10,6 @@ class C a where
bang' :: DecsQ
bang' = return [
- InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [
+ InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
DataInstD [] ''D [ConT ''Int] Nothing [
NormalC (mkName "T") []] []]]
diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout
index 8308c5b67d..8547e53fd6 100644
--- a/testsuite/tests/th/T8625.stdout
+++ b/testsuite/tests/th/T8625.stdout
@@ -1,2 +1,2 @@
-[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)) []]]
diff --git a/testsuite/tests/th/TH_overlaps.hs b/testsuite/tests/th/TH_overlaps.hs
new file mode 100644
index 0000000000..9fd2180dcb
--- /dev/null
+++ b/testsuite/tests/th/TH_overlaps.hs
@@ -0,0 +1,29 @@
+{-# 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)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index d562836ebd..648f7c932f 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -26,6 +26,8 @@ test('TH_repGuard', normal, compile, ['-v0'])
test('TH_repGuardOutput', normal, compile_and_run, [''])
test('TH_repPatSig', normal, compile_fail, [''])
+test('TH_overlaps', normal, compile, ['-v0'])
+
test('TH_spliceE5',
extra_clean(['TH_spliceE5_Lib.hi', 'TH_spliceE5_Lib.o']),
multimod_compile_and_run,
View Lorry Controller Status