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 }))
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]
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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*
......
[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
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)) []]]]
......@@ -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)) []]]]
......@@ -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])
[]
] })
......
......@@ -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)
]
......
......@@ -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))]]
......@@ -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") []] []]]
[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)) []]]
{-# 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'])
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,
......
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