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

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]

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

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

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]

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

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

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

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

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

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*
 

testsuite/tests/ghci/scripts/T4127.stdout

-[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)) []]]

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)) []]]]
 

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)) []]]]
 

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]) 
                          []
               ] })

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)    
     ] 

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))]]

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") []] []]]

testsuite/tests/th/T8625.stdout

-[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)) []]]

testsuite/tests/th/TH_overlaps.hs

+{-# 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)

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,