Commit 1993ee4b authored by mikhail.vorozhtsov's avatar mikhail.vorozhtsov Committed by Simon Peyton Jones
Browse files

TH: Pragmas refactoring.

Also adds RULES and 'SPECIALIZE instance' support.
parent ca9986a3
......@@ -71,7 +71,7 @@ module BasicTypes(
Activation(..), isActive, isActiveIn,
isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
InlineSpec(..),
InlineSpec(..), isEmptyInlineSpec,
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma,
......
......@@ -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
......@@ -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
......
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