From 6d0e2f288a34f12f5e3228415351d5bb4280c814 Mon Sep 17 00:00:00 2001
From: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Date: Tue, 10 Jul 2012 21:37:42 +0700
Subject: [PATCH] TH: Pragmas refactoring.
Also adds RULES and 'SPECIALIZE instance' support.
MERGED from commit 1993ee4ba8d30d6774c2330477a1eecf865dfa1f
---
compiler/basicTypes/BasicTypes.lhs | 2 +-
compiler/deSugar/DsMeta.hs | 253 ++++++++++++++++++-----------
compiler/hsSyn/Convert.lhs | 92 +++++++----
3 files changed, 216 insertions(+), 131 deletions(-)
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 86b93ab9a245..2760156e1cf3 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -71,7 +71,7 @@ module BasicTypes(
Activation(..), isActive, isActiveIn,
isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
- InlineSpec(..),
+ InlineSpec(..), isEmptyInlineSpec,
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma,
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 4d07c8c34e36..874f8b0f4100 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -131,11 +131,12 @@ repTopDs group
val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD (hs_instds group) ;
- for_ds <- mapM repForD (hs_fords group) ;
+ rule_ds <- mapM repRuleD (hs_ruleds group) ;
+ for_ds <- mapM repForD (hs_fords group) ;
-- more needed
return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ fix_ds
- ++ inst_ds ++ for_ds) }) ;
+ ++ inst_ds ++ rule_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
@@ -411,6 +412,25 @@ repFixD (L loc (FixitySig name (Fixity prec dir)))
; dec <- rep2 rep_fn [prec', name']
; return (loc, dec) }
+repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
+ = do { n' <- coreStringLit $ unpackFS n
+ ; phases <- repPhases act
+ ; bndrs' <- mapM repRuleBndr bndrs >>= coreList ruleBndrQTyConName
+ ; lhs' <- repLE lhs
+ ; rhs' <- repLE rhs
+ ; pragma <- repPragRule n' bndrs' lhs' rhs' phases
+ ; return (loc, pragma) }
+
+repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
+repRuleBndr (RuleBndr n)
+ = do { MkC n' <- lookupLOcc n
+ ; rep2 ruleVarName [n'] }
+repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
+ = do { MkC n' <- lookupLOcc n
+ ; MkC ty' <- repLTy ty
+ ; rep2 typedRuleVarName [n', ty'] }
+
ds_msg :: SDoc
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
@@ -541,6 +561,7 @@ rep_sig (L _ (GenericSig nm _)) = failWithDs msg
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
+rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc
rep_sig _ = return []
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
@@ -570,9 +591,11 @@ rep_inline :: Located Name
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
- = do { nm1 <- lookupLOcc nm
- ; ispec1 <- rep_InlinePrag ispec
- ; pragma <- repPragInl nm1 ispec1
+ = do { nm1 <- lookupLOcc nm
+ ; inline <- repInline $ inl_inline ispec
+ ; rm <- repRuleMatch $ inl_rule ispec
+ ; phases <- repPhases $ inl_act ispec
+ ; pragma <- repPragInl nm1 inline rm phases
; return [(loc, pragma)]
}
@@ -581,43 +604,39 @@ rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty
- ; pragma <- if isDefaultInlinePragma ispec
- then repPragSpec nm1 ty1 -- SPECIALISE
- else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
- ; repPragSpecInl nm1 ty1 ispec1 }
+ ; phases <- repPhases $ inl_act ispec
+ ; let inline = inl_inline ispec
+ ; pragma <- if isEmptyInlineSpec inline
+ then -- SPECIALISE
+ repPragSpec nm1 ty1 phases
+ else -- SPECIALISE INLINE
+ do { inline1 <- repInline inline
+ ; repPragSpecInl nm1 ty1 inline1 phases }
; return [(loc, pragma)]
}
+rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialiseInst ty loc
+ = do { ty1 <- repLTy ty
+ ; pragma <- repPragSpecInst ty1
+ ; return [(loc, pragma)] }
+
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline = dataCon noInlineDataConName
repInline Inline = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec = notHandled "repInline" (ppr spec)
--- Extract all the information needed to build a TH.InlinePrag
---
-rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
- -> DsM (Core TH.InlineSpecQ)
-rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
- | Just (flag, phase) <- activation1
- = do { inline1 <- repInline inline
- ; repInlineSpecPhase inline1 match1 flag phase }
- | otherwise
- = do { inline1 <- repInline inline
- ; repInlineSpecNoPhase inline1 match1 }
- where
- match1 = coreBool (rep_RuleMatchInfo match)
- activation1 = rep_Activation activation
- rep_RuleMatchInfo FunLike = False
- rep_RuleMatchInfo ConLike = True
-
- rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
- rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
- rep_Activation (ActiveBefore phase) = Just (coreBool False,
- MkC $ mkIntExprInt phase)
- rep_Activation (ActiveAfter phase) = Just (coreBool True,
- MkC $ mkIntExprInt phase)
+repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
+repRuleMatch ConLike = dataCon conLikeDataConName
+repRuleMatch FunLike = dataCon funLikeDataConName
+repPhases :: Activation -> DsM (Core TH.Phases)
+repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
+ ; dataCon' beforePhaseDataConName [arg] }
+repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i
+ ; dataCon' fromPhaseDataConName [arg] }
+repPhases _ = dataCon allPhasesDataConName
-------------------------------------------------------
-- Types
@@ -1389,9 +1408,12 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
rep2 n xs = do { id <- dsLookupGlobalId n
; return (MkC (foldl App (Var id) xs)) }
+dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
+dataCon' n args = do { id <- dsLookupDataCon n
+ ; return $ MkC $ mkConApp id args }
+
dataCon :: Name -> DsM (Core a)
-dataCon n = do { id <- dsLookupDataCon n
- ; return $ MkC $ mkConApp id [] }
+dataCon n = dataCon' n []
-- Then we make "repConstructors" which use the phantom types for each of the
-- smart constructors of the Meta.Meta datatypes.
@@ -1603,16 +1625,28 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
-repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
-repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+ = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
+ -> DsM (Core TH.DecQ)
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+ = rep2 pragSpecDName [nm, ty, phases]
-repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
+repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
+ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+ = rep2 pragSpecInlDName [nm, ty, inline, phases]
-repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
- -> DsM (Core TH.DecQ)
-repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
- = rep2 pragSpecInlDName [nm, ty, ispec]
+repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
+ -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+ = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
-> DsM (Core TH.DecQ)
@@ -1625,16 +1659,6 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki]
-repInlineSpecNoPhase :: Core TH.Inline -> Core Bool
- -> DsM (Core TH.InlineSpecQ)
-repInlineSpecNoPhase (MkC inline) (MkC conlike)
- = rep2 inlineSpecNoPhaseName [inline, conlike]
-
-repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int
- -> DsM (Core TH.InlineSpecQ)
-repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
- = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
-
repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
@@ -1851,11 +1875,7 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------- Bool, Literals & Variables -------------------
-
-coreBool :: Bool -> Core Bool
-coreBool False = MkC $ mkConApp falseDataCon []
-coreBool True = MkC $ mkConApp trueDataCon []
+------------ Literals & Variables -------------------
coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExprInt i))
@@ -1923,7 +1943,8 @@ templateHaskellNames = [
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceDName, sigDName, forImpDName,
- pragInlDName, pragSpecDName, pragSpecInlDName,
+ pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+ pragRuleDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
tySynInstDName, infixLDName, infixRDName, infixNDName,
-- Cxt
@@ -1957,8 +1978,12 @@ templateHaskellNames = [
interruptibleName,
-- Inline
noInlineDataConName, inlineDataConName, inlinableDataConName,
- -- InlineSpec
- inlineSpecNoPhaseName, inlineSpecPhaseName,
+ -- RuleMatch
+ conLikeDataConName, funLikeDataConName,
+ -- Phases
+ allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
+ -- RuleBndr
+ ruleVarName, typedRuleVarName,
-- FunDep
funDepName,
-- FamFlavour
@@ -1971,7 +1996,7 @@ templateHaskellNames = [
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
- predQTyConName, decsQTyConName,
+ predQTyConName, decsQTyConName, ruleBndrQTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -2130,29 +2155,31 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
- pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
- newtypeInstDName, tySynInstDName,
+ pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
+ familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName :: Name
-funDName = libFun (fsLit "funD") funDIdKey
-valDName = libFun (fsLit "valD") valDIdKey
-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
-sigDName = libFun (fsLit "sigD") sigDIdKey
-forImpDName = libFun (fsLit "forImpD") forImpDIdKey
-pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
-pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
-pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
-familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
-familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
-dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
-newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
-tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
-infixLDName = libFun (fsLit "infixLD") infixLDIdKey
-infixRDName = libFun (fsLit "infixRD") infixRDIdKey
-infixNDName = libFun (fsLit "infixND") infixNDIdKey
+funDName = libFun (fsLit "funD") funDIdKey
+valDName = libFun (fsLit "valD") valDIdKey
+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
+sigDName = libFun (fsLit "sigD") sigDIdKey
+forImpDName = libFun (fsLit "forImpD") forImpDIdKey
+pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
+pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
+pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
+pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
+pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
+familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey
+familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
+dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
+newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
+tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
+infixLDName = libFun (fsLit "infixLD") infixLDIdKey
+infixRDName = libFun (fsLit "infixRD") infixRDIdKey
+infixNDName = libFun (fsLit "infixND") infixNDIdKey
-- type Ctxt = ...
cxtName :: Name
@@ -2243,10 +2270,21 @@ noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
--- data InlineSpec = ...
-inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
-inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
-inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
+fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
+-- data RuleBndr = ...
+ruleVarName, typedRuleVarName :: Name
+ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
-- data FunDep = ...
funDepName :: Name
@@ -2260,12 +2298,13 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
- patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
-matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
-clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
-expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
-stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
-decQTyConName = libTc (fsLit "DecQ") decQTyConKey
+ patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
+ ruleBndrQTyConName :: Name
+matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
+clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
+expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
+stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
+decQTyConName = libTc (fsLit "DecQ") decQTyConKey
decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
conQTyConName = libTc (fsLit "ConQ") conQTyConKey
strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
@@ -2275,6 +2314,7 @@ fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
predQTyConName = libTc (fsLit "PredQ") predQTyConKey
+ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -2292,7 +2332,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
- predQTyConKey, decsQTyConKey :: Unique
+ predQTyConKey, decsQTyConKey, ruleBndrQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -2320,6 +2360,7 @@ predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
tyVarBndrTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
+ruleBndrQTyConKey = mkPreludeTyConUnique 227
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in PrelNames
@@ -2443,7 +2484,8 @@ parSIdKey = mkPreludeMiscIdUnique 323
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
- pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
+ pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
+ familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330
@@ -2458,6 +2500,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339
pragSpecDIdKey = mkPreludeMiscIdUnique 340
pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
+pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
+pragRuleDIdKey = mkPreludeMiscIdUnique 413
familyNoKindDIdKey = mkPreludeMiscIdUnique 342
familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344
@@ -2556,10 +2600,16 @@ noInlineDataConKey = mkPreludeDataConUnique 40
inlineDataConKey = mkPreludeDataConUnique 41
inlinableDataConKey = mkPreludeDataConUnique 42
--- data InlineSpec =
-inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
-inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 412
-inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 413
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 43
+funLikeDataConKey = mkPreludeDataConUnique 44
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey = mkPreludeDataConUnique 45
+fromPhaseDataConKey = mkPreludeDataConUnique 46
+beforePhaseDataConKey = mkPreludeDataConUnique 47
-- data FunDep = ...
funDepIdKey :: Unique
@@ -2576,3 +2626,8 @@ quoteExpKey = mkPreludeMiscIdUnique 418
quotePatKey = mkPreludeMiscIdUnique 419
quoteDecKey = mkPreludeMiscIdUnique 420
quoteTypeKey = mkPreludeMiscIdUnique 421
+
+-- data RuleBndr = ...
+ruleVarIdKey, typedRuleVarIdKey :: Unique
+ruleVarIdKey = mkPreludeMiscIdUnique 422
+typedRuleVarIdKey = mkPreludeMiscIdUnique 423
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 376ff236b7f8..847d90b94403 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -157,8 +157,7 @@ cvtDec (TH.InfixD fx nm)
; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
cvtDec (PragmaD prag)
- = do { prag' <- cvtPragmaD prag
- ; returnL $ Hs.SigD prag' }
+ = cvtPragmaD prag
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
@@ -410,38 +409,69 @@ cvt_conv TH.StdCall = StdCallConv
-- Pragmas
------------------------------------------
-cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
-cvtPragmaD (InlineP nm ispec)
- = do { nm' <- vNameL nm
- ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
-
-cvtPragmaD (SpecialiseP nm ty opt_ispec)
+cvtPragmaD :: Pragma -> CvtM (LHsDecl RdrName)
+cvtPragmaD (InlineP nm inline rm phases)
+ = do { nm' <- vNameL nm
+ ; let dflt = dfltActivation inline
+ ; let ip = InlinePragma { inl_inline = cvtInline inline
+ , inl_rule = cvtRuleMatch rm
+ , inl_act = cvtPhases phases dflt
+ , inl_sat = Nothing }
+ ; returnL $ Hs.SigD $ InlineSig nm' ip }
+
+cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
- ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
-
-cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
-cvtInlineSpec Nothing
- = defaultInlinePragma
-cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
- = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
- , inl_inline = inl_spec, inl_sat = Nothing }
- where
- matchinfo = cvtRuleMatchInfo conlike
- opt_activation' = cvtActivation opt_activation
-
- cvtRuleMatchInfo False = FunLike
- cvtRuleMatchInfo True = ConLike
-
- inl_spec = case inline of
- TH.NoInline -> Hs.NoInline
- TH.Inline -> Hs.Inline
- TH.Inlinable -> Hs.Inlinable
+ ; let (inline', dflt) = case inline of
+ Just inline1 -> (cvtInline inline1, dfltActivation inline1)
+ Nothing -> (EmptyInlineSpec, AlwaysActive)
+ ; let ip = InlinePragma { inl_inline = inline'
+ , inl_rule = Hs.FunLike
+ , inl_act = cvtPhases phases dflt
+ , inl_sat = Nothing }
+ ; returnL $ Hs.SigD $ SpecSig nm' ty' ip }
+
+cvtPragmaD (SpecialiseInstP ty)
+ = do { ty' <- cvtType ty
+ ; returnL $ Hs.SigD $ SpecInstSig ty' }
+
+cvtPragmaD (RuleP nm bndrs lhs rhs phases)
+ = do { let nm' = mkFastString nm
+ ; let act = cvtPhases phases AlwaysActive
+ ; bndrs' <- mapM cvtRuleBndr bndrs
+ ; lhs' <- cvtl lhs
+ ; rhs' <- cvtl rhs
+ ; returnL $ Hs.RuleD $ HsRule nm' act bndrs'
+ lhs' placeHolderNames
+ rhs' placeHolderNames
+ }
- cvtActivation Nothing | inline == TH.NoInline = NeverActive
- | otherwise = AlwaysActive
- cvtActivation (Just (False, phase)) = ActiveBefore phase
- cvtActivation (Just (True , phase)) = ActiveAfter phase
+dfltActivation :: TH.Inline -> Activation
+dfltActivation TH.NoInline = NeverActive
+dfltActivation _ = AlwaysActive
+
+cvtInline :: TH.Inline -> Hs.InlineSpec
+cvtInline TH.NoInline = Hs.NoInline
+cvtInline TH.Inline = Hs.Inline
+cvtInline TH.Inlinable = Hs.Inlinable
+
+cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
+cvtRuleMatch TH.ConLike = Hs.ConLike
+cvtRuleMatch TH.FunLike = Hs.FunLike
+
+cvtPhases :: TH.Phases -> Activation -> Activation
+cvtPhases AllPhases dflt = dflt
+cvtPhases (FromPhase i) _ = ActiveAfter i
+cvtPhases (BeforePhase i) _ = ActiveBefore i
+
+cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
+cvtRuleBndr (RuleVar n)
+ = do { n' <- vNameL n
+ ; return $ Hs.RuleBndr n' }
+cvtRuleBndr (TypedRuleVar n ty)
+ = do { n' <- vNameL n
+ ; ty' <- cvtType ty
+ ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
---------------------------------------------------
-- Declarations
--
GitLab