diff options
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) ---------------------------------------------------------- |