diff options
| -rw-r--r-- | compiler/GHC/Builtin/Names/TH.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/th/T21463.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 33 insertions, 8 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 98f8dacde0..2eb5e13530 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -71,7 +71,7 @@ templateHaskellNames = [ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceWithOverlapDName, standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, - pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, dataInstDName, newtypeInstDName, tySynInstDName, @@ -360,7 +360,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName, patSynSigDName, - pragCompleteDName, implicitParamBindDName :: Name + pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -375,6 +375,7 @@ defaultDName = libFun (fsLit "defaultD") defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey @@ -595,11 +596,10 @@ quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey -- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName, opaqueDataConName :: Name +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey inlineDataConName = thCon (fsLit "Inline") inlineDataConKey inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey -opaqueDataConName = thCon (fsLit "Opaque") opaqueDataConKey -- data RuleMatch = ... conLikeDataConName, funLikeDataConName :: Name @@ -702,11 +702,10 @@ modNameTyConKey = mkPreludeTyConUnique 239 -- If you want to change this, make sure you check in GHC.Builtin.Names -- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey, opaqueDataConKey :: Unique +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique noInlineDataConKey = mkPreludeDataConUnique 200 inlineDataConKey = mkPreludeDataConUnique 201 inlinableDataConKey = mkPreludeDataConUnique 202 -opaqueDataConKey = mkPreludeDataConUnique 203 -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique @@ -888,7 +887,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey, defaultDIdKey :: Unique + kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 320 valDIdKey = mkPreludeMiscIdUnique 321 dataDIdKey = mkPreludeMiscIdUnique 322 @@ -923,6 +922,7 @@ pragCompleteDIdKey = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 kiSigDIdKey = mkPreludeMiscIdUnique 352 defaultDIdKey = mkPreludeMiscIdUnique 353 +pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index ce986f7436..6718169bc3 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1084,6 +1084,13 @@ rep_inline :: LocatedN Name -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_inline nm ispec loc + | Opaque {} <- inl_inline ispec + = do { nm1 <- lookupLOcc nm + ; opq <- repPragOpaque nm1 + ; return [(loc, opq)] + } + +rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm ; inline <- repInline $ inl_inline ispec ; rm <- repRuleMatch $ inl_rule ispec @@ -1118,7 +1125,11 @@ rep_specialiseInst ty loc repInline :: InlineSpec -> MetaM (Core TH.Inline) repInline (NoInline _ ) = dataCon noInlineDataConName -repInline (Opaque _ ) = dataCon opaqueDataConName +-- There is a mismatch between the TH and GHC representation because +-- OPAQUE pragmas can't have phase activation annotations (which is +-- enforced by the TH API), therefore they are desugared to OpaqueP rather than +-- InlineP, see special case in rep_inline. +repInline (Opaque _ ) = panic "repInline: Opaque" repInline (Inline _ ) = dataCon inlineDataConName repInline (Inlinable _ ) = dataCon inlinableDataConName repInline NoUserInlinePrag = notHandled ThNoUserInline @@ -2602,6 +2613,9 @@ repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) = rep2 pragInlDName [nm, inline, rm, phases] +repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec)) +repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm] + repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases -> MetaM (Core (M TH.Dec)) repPragSpec (MkC nm) (MkC ty) (MkC phases) diff --git a/testsuite/tests/th/T21463.hs b/testsuite/tests/th/T21463.hs new file mode 100644 index 0000000000..bec226f72d --- /dev/null +++ b/testsuite/tests/th/T21463.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +main :: IO () +main = print + $([| let f :: Int -> Int + f x = x + 1 + {-# OPAQUE f #-} + in f 41 + |]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 2a003b8141..ec79e19249 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -538,6 +538,7 @@ test('T20060', normal, compile, ['']) test('T20179', normal, compile_fail, ['']) test('T17820a', normal, compile_fail, ['']) test('T17820b', normal, compile_fail, ['']) +test('T21463', normal, compile, ['']) test('T17820c', normal, compile_fail, ['']) test('T17820d', normal, compile_fail, ['']) test('T17820e', normal, compile_fail, ['']) |