diff options
Diffstat (limited to 'compiler/GHC/Hs/Expr.hs')
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 318 |
1 files changed, 194 insertions, 124 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index d37c8ed914..f70d5c0382 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -7,13 +7,16 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -28,7 +31,6 @@ import GhcPrelude import GHC.Hs.Decls import GHC.Hs.Pat import GHC.Hs.Lit -import GHC.Hs.PlaceHolder ( NameOrRdrName ) import GHC.Hs.Extension import GHC.Hs.Types import GHC.Hs.Binds @@ -89,14 +91,57 @@ type PostTcExpr = HsExpr GhcTc type PostTcTable = [(Name, PostTcExpr)] ------------------------- +{- Note [NoSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~ +Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc) +for several reasons: + + 1. As described in Note [Rebindable if] + + 2. In order to suppress "not in scope: xyz" messages when a bit of + rebindable syntax does not apply. For example, when using an irrefutable + pattern in a BindStmt, we don't need a `fail` operator. + + 3. Rebindable syntax might just not make sense. For example, a BodyStmt + contains the syntax for `guard`, but that's used only in monad comprehensions. + If we had more of a whiz-bang type system, we might be able to rule this + case out statically. +-} + -- | Syntax Expression -- --- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, --- by the renamer. It's used for rebindable syntax. +-- SyntaxExpr is represents the function used in interpreting rebindable +-- syntax. In the parser, we have no information to supply; in the renamer, +-- we have the name of the function (but see +-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle) +-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'. +-- +-- In some contexts, rebindable syntax is not implemented, and so we have +-- constructors to represent that possibility in both the renamer and +-- typechecker instantiations. -- -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for -- @(>>=)@, and then instantiated by the type checker with its type args -- etc +type family SyntaxExpr p + +-- Defining SyntaxExpr in two stages allows for better type inference, because +-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, +-- noSyntaxExpr would be ambiguous. +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: *) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = SyntaxExprRn + SyntaxExprGhc 'Typechecked = SyntaxExprTc + +-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. +data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr + | NoSyntaxExprRn + +-- | An expression with wrappers, used for rebindable syntax -- -- This should desugar to -- @@ -104,45 +149,43 @@ type PostTcTable = [(Name, PostTcExpr)] -- > (syn_arg_wraps[1] arg1) ... -- -- where the actual arguments come from elsewhere in the AST. --- This could be defined using @GhcPass p@ and such, but it's --- harder to get it all to work out that way. ('noSyntaxExpr' is hard to --- write, for example.) -data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } +data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + | NoSyntaxExprTc -- See Note [NoSyntaxExpr] -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SyntaxExpr (GhcPass p) - -- Before renaming, and sometimes after, - -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField - (HsString NoSourceText - (fsLit "noSyntaxExpr")) - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. -mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) -mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the --- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name - -- don't care about filling in syn_arg_wraps because we're clearly - -- not past the typechecker - -instance OutputableBndrId p - => Outputable (SyntaxExpr (GhcPass p)) where - ppr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) +noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after + -- See Note [NoSyntaxExpr] +noSyntaxExpr = case ghcPass @p of + GhcPs -> noExtField + GhcRn -> NoSyntaxExprRn + GhcTc -> NoSyntaxExprTc + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn +mkSyntaxExpr = SyntaxExprRn + +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). +mkRnSyntaxExpr :: Name -> SyntaxExprRn +mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name + +instance Outputable SyntaxExprRn where + ppr (SyntaxExprRn expr) = ppr expr + ppr NoSyntaxExprRn = text "<no syntax expr>" + +instance Outputable SyntaxExprTc where + ppr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) = sdocWithDynFlags $ \ dflags -> getPprStyle $ \s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags @@ -150,6 +193,8 @@ instance OutputableBndrId p <> braces (ppr res_wrap) else ppr expr + ppr NoSyntaxExprTc = text "<no syntax expr>" + -- | Command Syntax Table (for Arrow syntax) type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] @@ -330,10 +375,11 @@ data HsExpr p -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (XIf p) - (Maybe (SyntaxExpr p)) -- cond function - -- Nothing => use the built-in 'if' - -- See Note [Rebindable if] + | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use + -- rebindable syntax + (SyntaxExpr p) -- cond function + -- NoSyntaxExpr => use the built-in 'if' + -- See Note [Rebindable if] (LHsExpr p) -- predicate (LHsExpr p) -- then part (LHsExpr p) -- else part @@ -364,7 +410,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsDo (XDo p) -- Type of the whole expression - (HsStmtContext Name) -- The parameterisation is unimportant + (HsStmtContext GhcRn) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts @@ -506,16 +552,6 @@ data HsExpr p -- Expressions annotated with pragmas, written as {-# ... #-} | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) - --------------------------------------- - -- Finally, HsWrap appears only in typechecker output - -- The contained Expr is *NOT* itself an HsWrap. - -- See Note [Detecting forced eta expansion] in DsExpr. This invariant - -- is maintained by GHC.Hs.Utils.mkHsWrap. - - | HsWrap (XWrap p) - HsWrapper -- TRANSLATION - (HsExpr p) - | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor @@ -532,12 +568,22 @@ data RecordUpdTc = RecordUpdTc -- _non-empty_ list of DataCons that have -- all the upd'd fields - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] - } deriving Data + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } + +-- | HsWrap appears only in typechecker output +-- Invariant: The contained Expr is *NOT* itself an HsWrap. +-- See Note [Detecting forced eta expansion] in DsExpr. This invariant +-- is maintained by GHC.Hs.Utils.mkHsWrap. +-- hs_syn is something like HsExpr or HsCmd +data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper + (hs_syn GhcTc) -- the thing that is wrapped + +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) -- --------------------------------------------------------------------- @@ -570,7 +616,10 @@ type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] type instance XCase (GhcPass _) = NoExtField -type instance XIf (GhcPass _) = NoExtField + +type instance XIf GhcPs = Bool -- True <=> might use rebindable syntax +type instance XIf GhcRn = NoExtField +type instance XIf GhcTc = NoExtField type instance XMultiIf GhcPs = NoExtField type instance XMultiIf GhcRn = NoExtField @@ -618,7 +667,10 @@ type instance XBinTick (GhcPass _) = NoExtField type instance XPragE (GhcPass _) = NoExtField type instance XWrap (GhcPass _) = NoExtField -type instance XXExpr (GhcPass _) = NoExtCon + +type instance XXExpr GhcPs = NoExtCon +type instance XXExpr GhcRn = NoExtCon +type instance XXExpr GhcTc = HsWrap HsExpr -- --------------------------------------------------------------------- @@ -732,7 +784,12 @@ Because we allow an 'if' to return *unboxed* results, thus whereas that would not be possible using a all to a polymorphic function (because you can't call a polymorphic function at an unboxed type). -So we use Nothing to mean "use the old built-in typing rule". +So we use NoSyntaxExpr to mean "use the old built-in typing rule". + +A further complication is that, in the `deriving` code, we never want +to use rebindable syntax. So, even in GhcPs, we want to denote whether +to use rebindable syntax or not. This is done via the type instance +for XIf GhcPs. Note [Record Update HsWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1002,16 +1059,12 @@ ppr_expr (ExprWithTySig _ expr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (HsWrap _ co_fn e) - = pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) - ppr_expr (HsSpliceE _ s) = pprSplice s ppr_expr (HsBracket _ b) = pprHsBracket b ppr_expr (HsRnBracketOut _ e []) = ppr e ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e -ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> ppr ps +ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps) ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] @@ -1034,15 +1087,24 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) ppr exp, text ")"] ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x +ppr_expr (XExpr x) = case ghcPass @p of + GhcPs -> ppr x + GhcRn -> ppr x + GhcTc -> case x of + HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e + else pprExpr e) + -ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) -ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e -ppr_infix_expr _ = Nothing +ppr_infix_expr (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x + = ppr_infix_expr e +ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) @@ -1097,7 +1159,7 @@ pprParendExpr p expr -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs -- parentheses under precedence @p@. -hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool +hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool hsExprNeedsParens p = go where go (HsVar{}) = False @@ -1130,7 +1192,6 @@ hsExprNeedsParens p = go go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False go (HsPragE{}) = p >= appPrec - go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False go (HsBracket{}) = False go (HsRnBracketOut{}) = False @@ -1141,11 +1202,18 @@ hsExprNeedsParens p = go go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False - go (XExpr{}) = True + go (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x + = go e + + | otherwise + = True + -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. -parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) | hsExprNeedsParens p e = L loc (HsPar noExtField le) | otherwise = le @@ -1154,7 +1222,7 @@ stripParensHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) stripParensHsExpr (L _ (HsPar _ e)) = stripParensHsExpr e stripParensHsExpr e = e -isAtomicHsExpr :: HsExpr id -> Bool +isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsConLikeOut {}) = True @@ -1163,9 +1231,11 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True +isAtomicHsExpr (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x = isAtomicHsExpr e isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where @@ -1258,10 +1328,10 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdIf (XCmdIf id) - (Maybe (SyntaxExpr id)) -- cond function - (LHsExpr id) -- predicate - (LHsCmd id) -- then part - (LHsCmd id) -- else part + (SyntaxExpr id) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', @@ -1287,11 +1357,6 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdWrap (XCmdWrap id) - HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point type instance XCmdArrApp GhcPs = NoExtField @@ -1311,7 +1376,13 @@ type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type type instance XCmdWrap (GhcPass _) = NoExtField -type instance XXCmd (GhcPass _) = NoExtCon + +type instance XXCmd GhcPs = NoExtCon +type instance XXCmd GhcRn = NoExtCon +type instance XXCmd GhcTc = HsWrap HsCmd + -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1403,8 +1474,6 @@ ppr_cmd (HsCmdLet _ (L _ binds) cmd) ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts -ppr_cmd (HsCmdWrap _ w cmd) - = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) @@ -1429,7 +1498,11 @@ ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) ppr_cmd (HsCmdArrForm _ op _ _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_cmd (XCmd x) = ppr x +ppr_cmd (XCmd x) = case ghcPass @p of + GhcPs -> ppr x + GhcRn -> ppr x + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop _ cmd) @@ -1502,7 +1575,7 @@ type LMatch id body = Located (Match id body) data Match p body = Match { m_ext :: XCMatch p body, - m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), + m_ctxt :: HsMatchContext (NoGhcTc p), -- See note [m_ctxt in Match] m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) @@ -1637,7 +1710,7 @@ pprPatBind :: forall bndr p body. (OutputableBndrId bndr, => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, - nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)] pprMatch :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc @@ -1678,7 +1751,7 @@ pprMatch match (pat2:pats2) = pats1 pprGRHSs :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc + => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only @@ -1688,7 +1761,7 @@ pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) pprGRHSs _ (XGRHSs x) = ppr x pprGRHS :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc + => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS _ [] body) = pp_rhs ctxt body @@ -1697,7 +1770,7 @@ pprGRHS ctxt (GRHS _ guards body) pprGRHS _ (XGRHS x) = ppr x -pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc +pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) {- @@ -1774,6 +1847,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + -- See Note [NoSyntaxExpr] (2) -- | 'ApplicativeStmt' represents an applicative expression built with -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the @@ -1947,6 +2021,7 @@ data ApplicativeArg idL -- match fails. -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + -- See Note [NoSyntaxExpr] (2) } | ApplicativeArgMany -- do { stmts; return vars } { xarg_app_arg_many :: (XApplicativeArgMany idL) @@ -2601,8 +2676,8 @@ pp_dotdot = text " .. " -- -- Context of a pattern match. This is more subtle than it would seem. See Note -- [Varieties of pattern matches]. -data HsMatchContext id -- Not an extensible tag - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ +data HsMatchContext p + = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@ , mc_fixity :: LexicalFixity -- ^ fixing of @f@ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? -- See Note [FunBind vs PatBind] @@ -2622,16 +2697,16 @@ data HsMatchContext id -- Not an extensible tag -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, + | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension, -- pattern guard, etc | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration - deriving Functor -deriving instance (Data id) => Data (HsMatchContext id) +deriving instance Data (HsMatchContext GhcPs) +deriving instance Data (HsMatchContext GhcRn) -instance OutputableBndr id => Outputable (HsMatchContext id) where +instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) ppr LambdaExpr = text "LambdaExpr" ppr CaseAlt = text "CaseAlt" @@ -2645,15 +2720,14 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" -isPatSynCtxt :: HsMatchContext id -> Bool +isPatSynCtxt :: HsMatchContext p -> Bool isPatSynCtxt ctxt = case ctxt of PatSyn -> True _ -> False --- | Haskell Statement Context. It expects to be parameterised with one of --- 'RdrName', 'Name' or 'Id' -data HsStmtContext id +-- | Haskell Statement Context. +data HsStmtContext p = ListComp | MonadComp @@ -2662,11 +2736,11 @@ data HsStmtContext id | ArrowExpr -- ^do-notation in an arrow-command context | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt - deriving Functor -deriving instance (Data id) => Data (HsStmtContext id) + | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt +deriving instance Data (HsStmtContext GhcPs) +deriving instance Data (HsStmtContext GhcRn) isComprehensionContext :: HsStmtContext id -> Bool -- Uses comprehension syntax [ e | quals ] @@ -2691,7 +2765,7 @@ isMonadCompContext :: HsStmtContext id -> Bool isMonadCompContext MonadComp = True isMonadCompContext _ = False -matchSeparator :: HsMatchContext id -> SDoc +matchSeparator :: HsMatchContext p -> SDoc matchSeparator (FunRhs {}) = text "=" matchSeparator CaseAlt = text "->" matchSeparator IfAlt = text "->" @@ -2706,8 +2780,8 @@ matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" matchSeparator PatSyn = panic "unused" -pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc +pprMatchContext :: Outputable (IdP p) + => HsMatchContext p -> SDoc pprMatchContext ctxt | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt | otherwise = text "a" <+> pprMatchContextNoun ctxt @@ -2716,7 +2790,7 @@ pprMatchContext ctxt want_an ProcExpr = True want_an _ = False -pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) +pprMatchContextNoun :: Outputable (IdP id) => HsMatchContext id -> SDoc pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) = text "equation for" @@ -2735,8 +2809,7 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" pprMatchContextNoun PatSyn = text "pattern synonym declaration" ----------------- -pprAStmtContext, pprStmtContext :: (Outputable id, - Outputable (NameOrRdrName id)) +pprAStmtContext, pprStmtContext :: Outputable (IdP id) => HsStmtContext id -> SDoc pprAStmtContext ctxt = article <+> pprStmtContext ctxt where @@ -2769,13 +2842,13 @@ pprStmtContext (TransStmtCtxt c) = ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) (pprStmtContext c) -instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p))) +instance OutputableBndrId p => Outputable (HsStmtContext (GhcPass p)) where ppr = pprStmtContext -- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id - => HsMatchContext id -> SDoc +matchContextErrString :: OutputableBndrId p + => HsMatchContext (GhcPass p) -> SDoc matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun matchContextErrString CaseAlt = text "case" matchContextErrString IfAlt = text "multi-way if" @@ -2797,10 +2870,7 @@ matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" -pprMatchInCtxt :: (OutputableBndrId idR, - -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) +pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) @@ -2809,7 +2879,7 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => HsStmtContext (IdP (GhcPass idL)) + => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _) |