diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-07-29 20:23:53 +0200 |
|---|---|---|
| committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-07-30 15:05:36 +0200 |
| commit | 251dc91486126f3f1d1692963d596e05186bb2b8 (patch) | |
| tree | 3dcfee1f81925974967e1a0ba4969bf8fe6771ae /compiler | |
| parent | 10678945c1d3261273a1d7a389d14a69f4e28567 (diff) | |
| download | haskell-wip/T20183.tar.gz | |
Disallow nonlinear fields in Template Haskell (#18378)wip/T20183
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/HsToCore/Errors/Ppr.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Errors/Types.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 19 |
3 files changed, 21 insertions, 1 deletions
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index c8bda5562b..c5f3aca1ec 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -165,6 +165,8 @@ instance Diagnostic DsMessage where text "Pragma for declaration of" <+> ppr decl ThSplicesWithinDeclBrackets -> mkMsg "Splices within declaration brackets" empty + ThNonLinearDataCon + -> mkMsg "Non-linear fields in data constructors" empty where mkMsg what doc = mkSimpleDecorated $ diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 9a98e764e2..1747ae7914 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -192,6 +192,7 @@ data ThRejectionReason | ThHaddockDocumentation | ThWarningAndDeprecationPragmas [LIdP GhcRn] | ThSplicesWithinDeclBrackets + | ThNonLinearDataCon data NegLiteralExtEnabled = YesUsingNegLiterals diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index f68a561957..ebda80c142 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2664,6 +2664,7 @@ repH98DataCon con details arg_tys <- repPrefixConArgs ps rep2 normalCName [unC con', unC arg_tys] InfixCon st1 st2 -> do + verifyLinearConstructors [st1, st2] arg1 <- repBangTy (hsScaledThing st1) arg2 <- repBangTy (hsScaledThing st2) rep2 infixCName [unC arg1, unC con', unC arg2] @@ -2688,10 +2689,26 @@ repGadtDataCons cons details res_ty rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, unC res_ty'] +-- TH currently only supports linear constructors. +-- We also accept the (->) arrow when -XLinearTypes is off, because this +-- denotes a linear field. +-- This check is not performed in repRecConArgs, since the GADT record +-- syntax currently does not have a way to mark fields as nonlinear. +verifyLinearConstructors :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM () +verifyLinearConstructors ps = do + linear <- lift $ xoptM LangExt.LinearTypes + let allGood = all (\st -> case hsMult st of + HsUnrestrictedArrow _ -> not linear + HsLinearArrow _ -> True + _ -> False) ps + unless allGood $ notHandled ThNonLinearDataCon + -- Desugar the arguments in a data constructor declared with prefix syntax. repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM (Core [M TH.BangType]) -repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps) +repPrefixConArgs ps = do + verifyLinearConstructors ps + repListM bangTypeTyConName repBangTy (map hsScaledThing ps) -- Desugar the arguments in a data constructor declared with record syntax. repRecConArgs :: LocatedL [LConDeclField GhcRn] |