diff options
author | romes <rodrigo.m.mesquita@gmail.com> | 2022-03-19 17:42:46 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-06-01 07:44:44 -0400 |
commit | 7975202ba9010c581918413808ee06fbab9ac85f (patch) | |
tree | ffebdbd9d9fcef2300b1a6d3950bb5dd3f8435c4 /compiler/GHC/HsToCore | |
parent | 392ce3fca5d33688add52309a05914efa163e6f6 (diff) | |
download | haskell-7975202ba9010c581918413808ee06fbab9ac85f.tar.gz |
TTG: Rework and improve splices
This commit redefines the structure of Splices in the AST.
We get rid of `HsSplice` which used to represent typed and untyped
splices, quasi quotes, and the result of splicing either an expression,
a type or a pattern.
Instead we have `HsUntypedSplice` which models an untyped splice or a
quasi quoter, which works in practice just like untyped splices.
The `HsExpr` constructor `HsSpliceE` which used to be constructed with
an `HsSplice` is split into `HsTypedSplice` and `HsUntypedSplice`. The
former is directly constructed with an `HsExpr` and the latter now takes
an `HsUntypedSplice`.
Both `HsType` and `Pat` constructors `HsSpliceTy` and `SplicePat` now
take an `HsUntypedSplice` instead of a `HsSplice` (remember only
/untyped splices/ can be spliced as types or patterns).
The result of splicing an expression, type, or pattern is now
comfortably stored in the extension fields `XSpliceTy`, `XSplicePat`,
`XUntypedSplice` as, respectively, `HsUntypedSpliceResult (HsType
GhcRn)`, `HsUntypedSpliceResult (Pat GhcRn)`, and `HsUntypedSpliceResult
(HsExpr GhcRn)`
Overall the TTG extension points are now better used to
make invalid states unrepresentable and model the progression between
stages better.
See Note [Lifecycle of an untyped splice, and PendingRnSplice]
and Note [Lifecycle of an typed splice, and PendingTcSplice] for more
details.
Updates haddock submodule
Fixes #21263
-------------------------
Metric Decrease:
hard_hole_fits
-------------------------
Diffstat (limited to 'compiler/GHC/HsToCore')
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 47 |
3 files changed, 27 insertions, 30 deletions
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 09cd86f952..eec4ba9de3 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -640,7 +640,8 @@ addTickHsExpr (HsPragE x p e) = liftM (HsPragE x p) (addTickLHsExpr e) addTickHsExpr e@(HsTypedBracket {}) = return e addTickHsExpr e@(HsUntypedBracket{}) = return e -addTickHsExpr e@(HsSpliceE {}) = return e +addTickHsExpr e@(HsTypedSplice{}) = return e +addTickHsExpr e@(HsUntypedSplice{}) = return e addTickHsExpr e@(HsGetField {}) = return e addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 84dd992037..5feee52901 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -487,9 +487,10 @@ dsExpr (RecordUpd x _ _) = dataConCantHappen x -- Template Haskell stuff -- See Note [The life cycle of a TH quotation] -dsExpr (HsTypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps -dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps -dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) +dsExpr (HsTypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsTypedSplice _ s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s) +dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 6718169bc3..5f08571bf2 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -157,36 +157,32 @@ getPlatform :: MetaM Platform getPlatform = targetPlatform <$> getDynFlags ----------------------------------------------------------------------------- -dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr - -> HsQuote GhcRn -- See Note [The life cycle of a TH quotation] - -> [PendingTcSplice] - -> DsM CoreExpr +dsBracket :: HsBracketTc -> DsM CoreExpr -- See Note [Desugaring Brackets] -- Returns a CoreExpr of type (M TH.Exp) -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! -dsBracket wrap brack splices - = do_brack brack +dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote = quote }) + = case quote of + VarBr _ _ n -> do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } + ExpBr _ e -> runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + PatBr _ p -> runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } + TypBr _ t -> runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } + DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } + DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL" where - runOverloaded act = do + Just wrap = mb_wrap -- Not used in VarBr case -- In the overloaded case we have to get given a wrapper, it is just - -- for variable quotations that there is no wrapper, because they + -- the VarBr case that there is no wrapper, because they -- have a simple type. - mw <- mkMetaWrappers (expectJust "runOverloaded" wrap) - runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw + + runOverloaded act = do { mw <- mkMetaWrappers wrap + ; runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw } new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } - do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL {}) = panic "dsUntypedBracket: unexpected DecBrL" - - {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1413,7 +1409,8 @@ repTy (HsKindSig _ t k) = do t1 <- repLTy t k1 <- repLTy k repTSig t1 k1 -repTy (HsSpliceTy _ splice) = repSplice splice +repTy (HsSpliceTy (HsUntypedSpliceNested n) _) = rep_splice n +repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level splice" (ppr t) repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 @@ -1460,13 +1457,8 @@ repRole (L _ Nothing) = rep2_nw inferRName [] -- Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice GhcRn -> MetaM (Core a) -- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ _ n _) = rep_splice n -repSplice (HsUntypedSplice _ _ n _) = rep_splice n -repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n -repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> MetaM (Core a) rep_splice splice_name @@ -1634,7 +1626,9 @@ repE (ArithSeq _ _ aseq) = ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE _ splice) = repSplice splice +repE (HsTypedSplice n _) = rep_splice n +repE (HsUntypedSplice (HsUntypedSpliceNested n) _) = rep_splice n +repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e) repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC repE (HsUnboundVar _ uv) = do occ <- occNameLit uv @@ -2101,7 +2095,8 @@ repP p@(NPat _ (L _ l) (Just _) _) repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } -repP (SplicePat _ splice) = repSplice splice +repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n +repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) repP other = notHandled (ThExoticPattern other) ---------------------------------------------------------- |