diff options
48 files changed, 1007 insertions, 602 deletions
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 89ca815ed5..12b0c838a6 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" -ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" -ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" -ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" -ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 2ab2acbe3f..d86077ea27 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -870,18 +870,6 @@ instance ( a ~ GhcPass p HsSpliceE _ x -> [ toHie $ L mspan x ] - EWildPat _ -> [] - EAsPat _ a b -> - [ toHie $ C Use a - , toHie b - ] - EViewPat _ a b -> - [ toHie a - , toHie b - ] - ELazyPat _ a -> - [ toHie a - ] XExpr _ -> [] instance ( a ~ GhcPass p diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index b86f4a147d..9052855c69 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -625,32 +625,6 @@ data HsExpr p (LHsExpr p) --------------------------------------- - -- These constructors only appear temporarily in the parser. - -- The renamer translates them into the Right Thing. - - | EWildPat (XEWildPat p) -- wildcard - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (XEAsPat p) - (Located (IdP p)) -- as pattern - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (XEViewPat p) - (LHsExpr p) -- view pattern - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern - - - --------------------------------------- -- 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 @@ -761,10 +735,6 @@ type instance XStatic GhcTc = NameSet type instance XTick (GhcPass _) = NoExt type instance XBinTick (GhcPass _) = NoExt type instance XTickPragma (GhcPass _) = NoExt -type instance XEWildPat (GhcPass _) = NoExt -type instance XEAsPat (GhcPass _) = NoExt -type instance XEViewPat (GhcPass _) = NoExt -type instance XELazyPat (GhcPass _) = NoExt type instance XWrap (GhcPass _) = NoExt type instance XXExpr (GhcPass _) = NoExt @@ -924,21 +894,12 @@ ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr (OpApp _ e1 op e2) - | Just pp_op <- should_print_infix (unLoc op) + | Just pp_op <- ppr_infix_expr (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where - should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar _ h@TrueExprHole{}) - = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix (EWildPat _) = Just (text "`_`") - should_print_infix (HsWrap _ _ e) = should_print_infix e - should_print_infix _ = Nothing - pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear @@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2) ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e ppr_expr (SectionL _ expr op) - = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly (conLikeName c) - HsUnboundVar _ h@TrueExprHole{} - -> pp_infixly (unboundVarOcc h) - _ -> pp_prefixly + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly v = (sep [pp_expr, v]) ppr_expr (SectionR _ op expr) - = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly (conLikeName c) - HsUnboundVar _ h@TrueExprHole{} - -> pp_infixly (unboundVarOcc h) - _ -> pp_prefixly + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) - pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc - pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly v = sep [v, pp_expr] ppr_expr (ExplicitTuple _ exprs boxity) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) @@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (EWildPat _) = char '_' -ppr_expr (ELazyPat _ e) = char '~' <> ppr e -ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e -ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e - ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written @@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = ppr x +ppr_infix_expr :: (OutputableBndrId (GhcPass 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 _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) +ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e +ppr_infix_expr _ = Nothing + ppr_apps :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] @@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go go (RecordUpd{}) = False go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False - go (EWildPat{}) = False - go (ELazyPat{}) = False - go (EAsPat{}) = False - go (EViewPat{}) = True go (HsSCC{}) = p >= appPrec go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 1bebec0896..1d14da20b9 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -539,10 +539,6 @@ type family XStatic x type family XTick x type family XBinTick x type family XTickPragma x -type family XEWildPat x -type family XEAsPat x -type family XEViewPat x -type family XELazyPat x type family XWrap x type family XXExpr x @@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) = , c (XTick x) , c (XBinTick x) , c (XTickPragma x) - , c (XEWildPat x) - , c (XEAsPat x) - , c (XEViewPat x) - , c (XELazyPat x) , c (XWrap x) , c (XXExpr x) ) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c23c320ac9..3c1ea8cc7d 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -58,7 +58,6 @@ module Lexer ( activeContext, nextIsEOF, getLexState, popLexState, pushLexState, ExtBits(..), - addWarning, lexTokenStream, AddAnn,mkParensApiAnn, commentToAnnotation @@ -2493,6 +2492,9 @@ class Monad m => MonadP m where -- more than one parse error per file. -- addError :: SrcSpan -> SDoc -> m () + -- | Add a warning to the accumulator. + -- Use 'getMessages' to get the accumulated warnings. + addWarning :: WarningFlag -> SrcSpan -> SDoc -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state. addFatalError :: SrcSpan -> SDoc -> m a @@ -2515,6 +2517,16 @@ instance MonadP P where es' = es `snocBag` errormsg in (ws, es') in POk s{messages=m'} () + addWarning option srcspan warning + = P $ \s@PState{messages=m, options=o} -> + let + m' d = + let (ws, es) = m d + warning' = makeIntoWarning (Reason option) $ + mkWarnMsg d srcspan alwaysQualify warning + ws' = if warnopt option o then ws `snocBag` warning' else ws + in (ws', es) + in POk s{messages=m'} () addFatalError span msg = addError span msg >> P PFailed getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) @@ -2524,20 +2536,6 @@ instance MonadP P where addAnnotationOnly l a v allocateComments l --- | Add a warning to the accumulator. --- Use 'getMessages' to get the accumulated warnings. -addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () -addWarning option srcspan warning - = P $ \s@PState{messages=m, options=o} -> - let - m' d = - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - in POk s{messages=m'} () - addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4bc3fa9ad0..80e197e039 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1064,7 +1064,8 @@ topdecl :: { LHsDecl GhcPs } -- The $(..) form is one possible form of infixexp -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp_top { sLL $1 $> $ mkSpliceDecl $1 } + | infixexp_top {% runECP_P $1 >>= \ $1 -> + return $ sLL $1 $> $ mkSpliceDecl $1 } -- Type classes -- @@ -1509,7 +1510,7 @@ decl_cls : at_decl_cls { $1 } -- A 'default' signature used with the generic-programming extension | 'default' infixexp '::' sigtypedoc - {% runExpCmdP $2 >>= \ $2 -> + {% runECP_P $2 >>= \ $2 -> do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) @@ -1649,8 +1650,8 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp - {%runExpCmdP $4 >>= \ $4 -> - runExpCmdP $6 >>= \ $6 -> + {%runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> ams (sLL $1 $> $ HsRule { rd_ext = noExt , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive @@ -1760,19 +1761,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } ----------------------------------------------------------------------------- -- Annotations annotation :: { LHsDecl GhcPs } - : '{-# ANN' name_var aexp '#-}' {% runExpCmdP $3 >>= \ $3 -> + : '{-# ANN' name_var aexp '#-}' {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } - | '{-# ANN' 'type' tycon aexp '#-}' {% runExpCmdP $4 >>= \ $4 -> + | '{-# ANN' 'type' tycon aexp '#-}' {% runECP_P $4 >>= \ $4 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (TypeAnnProvenance $3) $4)) [mo $1,mj AnnType $2,mc $5] } - | '{-# ANN' 'module' aexp '#-}' {% runExpCmdP $3 >>= \ $3 -> + | '{-# ANN' 'module' aexp '#-}' {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) ModuleAnnProvenance $3)) @@ -2393,8 +2394,8 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% runExpCmdP $2 >>= \ $2 -> - do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) + | '!' aexp rhs {% runECP_P $2 >>= \ $2 -> + do { let { e = patBuilderBang (getLoc $1) $2 ; l = comb2 $1 $> }; (ann, r) <- checkValDef SrcStrict e Nothing $3 ; runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ; @@ -2410,7 +2411,8 @@ decl_no_th :: { LHsDecl GhcPs } _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; return $! (sL l $ ValD noExt r) } } - | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; + | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 -> + do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; let { l = comb2 $1 $> }; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note @@ -2434,7 +2436,7 @@ decl :: { LHsDecl GhcPs } | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } - : '=' exp wherebinds {% runExpCmdP $2 >>= \ $2 -> return $ + : '=' exp wherebinds {% runECP_P $2 >>= \ $2 -> return $ sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2) @@ -2448,7 +2450,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } | gdrh { sL1 $1 [$1] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% runExpCmdP $4 >>= \ $4 -> + : '|' guardquals '=' exp {% runECP_P $4 >>= \ $4 -> ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } @@ -2456,7 +2458,8 @@ sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp_top '::' sigtypedoc - {% do { v <- checkValSigLhs $1 + {% do { $1 <- runECP_P $1 + ; v <- checkValSigLhs $1 ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] ; return (sLL $1 $> $ SigD noExt $ TypeSig noExt [v] (mkLHsSigWcType $3))} } @@ -2548,84 +2551,90 @@ quasiquote :: { Located (HsSplice GhcPs) } ; quoterId = mkQual varName (qual, quoter) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -exp :: { ExpCmdP } - : infixexp '::' sigtype {% runExpCmdP $1 >>= \ $1 -> - fmap ecFromExp $ - ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3)) +exp :: { ECP } + : infixexp '::' sigtype { ECP $ + runECP_PV $1 >>= \ $1 -> + amms (mkHsTySigPV (comb2 $1 $>) $1 $3) [mu AnnDcolon $2] } - | infixexp '-<' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '-<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3 HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1 HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '-<<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3 HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '>>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1 HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } -infixexp :: { ExpCmdP } +infixexp :: { ECP } : exp10 { $1 } - | infixexp qop exp10 { ExpCmdP $ - runExpCmdPV $1 >>= \ $1 -> - runExpCmdPV $3 >>= \ $3 -> - ams (sLL $1 $> (ecOpApp $1 $2 $3)) + | infixexp qop exp10 { ECP $ + superInfixOp $ + $2 >>= \ $2 -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator -infixexp_top :: { LHsExpr GhcPs } - : exp10_top {% runExpCmdP $1 } +infixexp_top :: { ECP } + : exp10_top { $1 } | infixexp_top qop exp10_top - {% runExpCmdP $3 >>= \ $3 -> + { ECP $ + superInfixOp $ + $2 >>= \ $2 -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> do { when (srcSpanEnd (getLoc $2) == srcSpanStart (getLoc $3) - && checkIfBang $2) $ + && checkIfBang (unLoc $2)) $ warnSpaceAfterBang (comb2 $2 $3); - ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) [mj AnnVal $2] } } -exp10_top :: { ExpCmdP } - : '-' fexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) +exp10_top :: { ECP } + : '-' fexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] } - | hpc_annot exp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | hpc_annot exp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } - | '{-# CORE' STRING '#-}' exp {% runExpCmdP $4 >>= \ $4 -> - fmap ecFromExp $ + | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation | fexp { $1 } -exp10 :: { ExpCmdP } +exp10 :: { ECP } : exp10_top { $1 } - | scc_annot exp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | scc_annot exp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } @@ -2668,175 +2677,172 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In ))) } -fexp :: { ExpCmdP } - : fexp aexp {% runExpCmdP $2 >>= \ $2 -> - runPV (checkBlockArguments $2) >>= \_ -> - return $ ExpCmdP $ - runExpCmdPV $1 >>= \ $1 -> - checkBlockArguments $1 >>= \_ -> - return (sLL $1 $> (ecHsApp $1 $2)) } - | fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 -> - runPV (checkBlockArguments $1) >>= \_ -> - fmap ecFromExp $ +fexp :: { ECP } + : fexp aexp { ECP $ + superFunArg $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $2 >>= \ $2 -> + mkHsAppPV (comb2 $1 $>) $1 $2 } + | fexp TYPEAPP atype {% runECP_P $1 >>= \ $1 -> + runPV (checkExpBlockArguments $1) >>= \_ -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } - | 'static' aexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | 'static' aexp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsStatic noExt $2) [mj AnnStatic $1] } | aexp { $1 } -aexp :: { ExpCmdP } - : qvar '@' aexp {% runExpCmdP $3 >>= \ $3 -> - fmap ecFromExp $ - ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } +aexp :: { ECP } + : qvar '@' aexp { ECP $ + runECP_PV $3 >>= \ $3 -> + amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } + | '~' aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } | '\\' apat apats '->' exp - { ExpCmdP $ - runExpCmdPV $5 >>= \ $5 -> - ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource + { ECP $ + runECP_PV $5 >>= \ $5 -> + amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource [sLL $1 $> $ Match { m_ext = noExt , m_ctxt = LambdaExpr , m_pats = $2:$3 , m_grhss = unguardedGRHSs $5 }])) [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp { ExpCmdP $ - runExpCmdPV $4 >>= \ $4 -> - ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4) + | 'let' binds 'in' exp { ECP $ + runECP_PV $4 >>= \ $4 -> + amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } | '\\' 'lcase' altslist {% runPV $3 >>= \ $3 -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (sLL $1 $> $ HsLamCase noExt (mkMatchGroup FromSource (snd $ unLoc $3))) (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% runExpCmdP $2 >>= \ $2 -> - return $ ExpCmdP $ - runExpCmdPV $5 >>= \ $5 -> - runExpCmdPV $8 >>= \ $8 -> - checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ ecHsIf $2 $5 $8) + {% runECP_P $2 >>= \ $2 -> + return $ ECP $ + runECP_PV $5 >>= \ $5 -> + runECP_PV $8 >>= \ $8 -> + amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8) (mj AnnIf $1:mj AnnThen $4 :mj AnnElse $7 :(map (\l -> mj AnnSemi l) (fst $3)) ++(map (\l -> mj AnnSemi l) (fst $6))) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (sLL $1 $> $ HsMultiIf noExt (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% runExpCmdP $2 >>= \ $2 -> - return $ ExpCmdP $ + | 'case' exp 'of' altslist {% runECP_P $2 >>= \ $2 -> + return $ ECP $ $4 >>= \ $4 -> - ams (cL (comb3 $1 $3 $4) $ - ecHsCase $2 (mkMatchGroup + amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | 'do' stmtlist { ExpCmdP $ + | 'do' stmtlist { ECP $ $2 >>= \ $2 -> - ams (cL (comb2 $1 $2) - (ecHsDo (mapLoc snd $2))) + amms (mkHsDoPV (comb2 $1 $2) (mapLoc snd $2)) (mj AnnDo $1:(fst $ unLoc $2)) } | 'mdo' stmtlist {% runPV $2 >>= \ $2 -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (cL (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp - {% (checkPattern <=< runExpCmdP) $2 >>= \ p -> - runExpCmdP $4 >>= \ $4@cmd -> - fmap ecFromExp $ + {% (checkPattern <=< runECP_P) $2 >>= \ p -> + runECP_P $4 >>= \ $4@cmd -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } | aexp1 { $1 } -aexp1 :: { ExpCmdP } - : aexp1 '{' fbinds '}' {% runExpCmdP $1 >>= \ $1 -> - do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - (snd $3) - ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3)) - ; fmap ecFromExp $ - checkRecordSyntax (sLL $1 $> r) }} +aexp1 :: { ECP } + : aexp1 '{' fbinds '}' { ECP $ + runECP_PV $1 >>= \ $1 -> + $3 >>= \ $3 -> + amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) + (moc $2:mcc $4:(fst $3)) } | aexp2 { $1 } -aexp2 :: { ExpCmdP } - : qvar { ecFromExp $ sL1 $1 (HsVar noExt $! $1) } - | qcon { ecFromExp $ sL1 $1 (HsVar noExt $! $1) } - | ipvar { ecFromExp $ sL1 $1 (HsIPVar noExt $! unLoc $1) } - | overloaded_label { ecFromExp $ sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } - | literal { ecFromExp $ sL1 $1 (HsLit noExt $! unLoc $1) } +aexp2 :: { ECP } + : qvar { ECP $ mkHsVarPV $! $1 } + | qcon { ECP $ mkHsVarPV $! $1 } + | ipvar { ecpFromExp $ sL1 $1 (HsIPVar noExt $! unLoc $1) } + | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } + | literal { ECP $ mkHsLitPV $! $1 } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) noExt) } - | INTEGER { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } - | RATIONAL { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } + | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } + | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' { ExpCmdP $ - runExpCmdPV $2 >>= \ $2 -> - ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] } - | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) - ; fmap ecFromExp $ - ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - - | '(#' texp '#)' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2) - (Present noExt $2)] Unboxed)) - [mo $1,mc $3] } - | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) - ; fmap ecFromExp $ - ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } - - | '[' list ']' {% fmap ecFromExp $ ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } - | '_' { ecFromExp $ sL1 $1 $ EWildPat noExt } + | '(' texp ')' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] } + | '(' tup_exprs ')' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) + ((mop $1:fst $2) ++ [mcp $3]) } + + | '(#' texp '#)' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)])) + [mo $1,mc $3] } + | '(#' tup_exprs '#)' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2)) + ((mo $1:fst $2) ++ [mc $3]) } + + | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] } + | '_' { ECP $ mkHsWildCardPV (getLoc $1) } -- Template Haskell Extension - | splice_exp { ecFromExp $1 } + | splice_untyped { ECP $ mkHsSplicePV $1 } + | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExt) $1 } - | SIMPLEQUOTE qvar {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } - | '[|' exp '|]' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | '[|' exp '|]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | '[||' exp '||]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ktype '|]' {% fmap ecFromExp $ + | '[t|' ktype '|]' {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } - | '[p|' infixexp '|]' {% (checkPattern <=< runExpCmdP) $2 >>= \p -> - fmap ecFromExp $ + | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% fmap ecFromExp $ + | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { ecFromExp $ sL1 $1 (HsSpliceE noExt (unLoc $1)) } + | quasiquote { ECP $ mkHsSplicePV $1 } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromCmd $ + | '(|' aexp2 cmdargs '|)' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrForm noExt $2 Prefix Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } @@ -2850,7 +2856,7 @@ splice_untyped :: { Located (HsSplice GhcPs) } (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } - | '$(' exp ')' {% runExpCmdP $2 >>= \ $2 -> + | '$(' exp ')' {% runECP_P $2 >>= \ $2 -> ams (sLL $1 $> $ mkUntypedSplice HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } @@ -2859,7 +2865,7 @@ splice_typed :: { Located (HsSplice GhcPs) } (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% runExpCmdP $2 >>= \ $2 -> + | '$$(' exp ')' {% runECP_P $2 >>= \ $2 -> ams (sLL $1 $> $ mkTypedSplice HasParens $2) [mj AnnOpenPTE $1,mj AnnCloseP $3] } @@ -2868,7 +2874,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } | {- empty -} { [] } acmd :: { LHsCmdTop GhcPs } - : aexp2 {% runExpCmdP $1 >>= \ cmd -> + : aexp2 {% runECP_P $1 >>= \ cmd -> return (sL1 cmd $ HsCmdTop noExt cmd) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } @@ -2886,7 +2892,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] } -- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas -texp :: { ExpCmdP } +texp :: { ECP } : exp { $1 } -- Note [Parsing sections] @@ -2900,98 +2906,112 @@ texp :: { ExpCmdP } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop {% runExpCmdP $1 >>= \ $1 -> - return $ ecFromExp $ + | infixexp qop {% runECP_P $1 >>= \ $1 -> + runPV $2 >>= \ $2 -> + return $ ecpFromExp $ sLL $1 $> $ SectionL noExt $1 $2 } - | qopm infixexp {% runExpCmdP $2 >>= \ $2 -> - return $ ecFromExp $ - sLL $1 $> $ SectionR noExt $1 $2 } + | qopm infixexp { ECP $ + superInfixOp $ + runECP_PV $2 >>= \ $2 -> + $1 >>= \ $1 -> + mkHsSectionR_PV (comb2 $1 $>) $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromExp $ - ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } + | exp '->' texp { ECP $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. -tup_exprs :: { ([AddAnn],SumOrTuple) } +tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } : texp commas_tup_tail - {% runExpCmdP $1 >>= \ $1 -> + { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } } - | texp bars {% runExpCmdP $1 >>= \ $1 -> return $ + | texp bars { runECP_PV $1 >>= \ $1 -> return $ (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } | commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } } | bars texp bars0 - {% runExpCmdP $2 >>= \ $2 -> return $ + { runECP_PV $2 >>= \ $2 -> return $ (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { (SrcSpan,[LHsTupArg GhcPs]) } +commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) } commas_tup_tail : commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma -tup_tail :: { [LHsTupArg GhcPs] } - : texp commas_tup_tail {% runExpCmdP $1 >>= \ $1 -> - addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Present noExt $1)) : snd $2) } - | texp {% runExpCmdP $1 >>= \ $1 -> - return [cL (gl $1) (Present noExt $1)] } - | {- empty -} { [noLoc missingTupArg] } +tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } + : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> + addAnnotation (gl $1) AnnComma (fst $2) >> + return ((cL (gl $1) (Just $1)) : snd $2) } + | texp { runECP_PV $1 >>= \ $1 -> + return [cL (gl $1) (Just $1)] } + | {- empty -} { return [noLoc Nothing] } ----------------------------------------------------------------------------- -- List expressions -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. -list :: { ([AddAnn],HsExpr GhcPs) } - : texp {% runExpCmdP $1 >>= \ $1 -> - return ([],ExplicitList noExt Nothing [$1]) } - | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } - | texp '..' {% runExpCmdP $1 >>= \ $1 -> - return ([mj AnnDotdot $2], - ArithSeq noExt Nothing (From $1)) } - | texp ',' exp '..' {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - return ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThen $1 $3)) } - | texp '..' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - return ([mj AnnDotdot $2], - ArithSeq noExt Nothing - (FromTo $1 $3)) } - | texp ',' exp '..' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - runExpCmdP $5 >>= \ $5 -> - return ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThenTo $1 $3 $5)) } +list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } + : texp { \loc -> runECP_PV $1 >>= \ $1 -> + mkHsExplicitListPV loc [$1] } + | lexps { \loc -> $1 >>= \ $1 -> + mkHsExplicitListPV loc (reverse $1) } + | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> + ams (cL loc $ ArithSeq noExt Nothing (From $1)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (cL loc $ ArithSeq noExt Nothing (FromThen $1 $3)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } + | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (cL loc $ ArithSeq noExt Nothing (FromTo $1 $3)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' exp { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + runECP_PV $5 >>= \ $5 -> + ams (cL loc $ ArithSeq noExt Nothing (FromThenTo $1 $3 $5)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } | texp '|' flattenedpquals - {% checkMonadComp >>= \ ctxt -> - runExpCmdP $1 >>= \ $1 -> - return ([mj AnnVbar $2], - mkHsComp ctxt (unLoc $3) $1) } - -lexps :: { Located [LHsExpr GhcPs] } - : lexps ',' texp {% runExpCmdP $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) + { \loc -> + checkMonadComp >>= \ ctxt -> + runECP_PV $1 >>= \ $1 -> + ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) + [mj AnnVbar $2] + >>= ecpFromExp' } + +lexps :: { forall b. DisambECP b => PV [Located b] } + : lexps ',' texp { $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + addAnnotation (gl $ head $ $1) AnnComma (gl $2) >> - return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } - | texp ',' texp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> + return (((:) $! $3) $! $1) } + | texp ',' texp { runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> [$3,$1]) } + return [$3,$1] } ----------------------------------------------------------------------------- -- List Comprehensions @@ -3039,20 +3059,20 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* - : 'then' exp {% runExpCmdP $2 >>= \ $2 -> return $ + : 'then' exp {% runECP_P $2 >>= \ $2 -> return $ sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } - | 'then' exp 'by' exp {% runExpCmdP $2 >>= \ $2 -> - runExpCmdP $4 >>= \ $4 -> + | 'then' exp 'by' exp {% runECP_P $2 >>= \ $2 -> + runECP_P $4 >>= \ $4 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3], \ss -> (mkTransformByStmt ss $2 $4)) } | 'then' 'group' 'using' exp - {% runExpCmdP $4 >>= \ $4 -> + {% runECP_P $4 >>= \ $4 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) } | 'then' 'group' 'by' exp 'using' exp - {% runExpCmdP $4 >>= \ $4 -> - runExpCmdP $6 >>= \ $6 -> + {% runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) } @@ -3078,7 +3098,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : '{' alts '}' { $2 >>= \ $2 -> return $ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } @@ -3088,14 +3108,14 @@ altslist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Locate | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { return $ noLoc ([],[]) } -alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) ,snd $ unLoc $2) } -alts1 :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 ';' alt { $1 >>= \ $1 -> $3 >>= \ $3 -> if null (snd $ unLoc $1) @@ -3113,7 +3133,7 @@ alts1 :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located >> return (sLL $1 $> ([],snd $ unLoc $1))) } | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) } -alt :: { forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs))) } +alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) } : pat alt_rhs { $2 >>= \ $2 -> ams (sLL $1 $> (Match { m_ext = noExt , m_ctxt = CaseAlt @@ -3121,18 +3141,18 @@ alt :: { forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs))) } , m_grhss = snd $ unLoc $2 })) (fst $ unLoc $2)} -alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (b GhcPs)))) } +alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) } : ralt wherebinds { $1 >>= \alt -> return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) } -ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) } - : '->' exp { runExpCmdPV $2 >>= \ $2 -> +ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } + : '->' exp { runECP_PV $2 >>= \ $2 -> ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) [mu AnnRarrow $1] } | gdpats { $1 >>= \gdpats -> return $ sL1 gdpats (reverse (unLoc gdpats)) } -gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) } +gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } : gdpats gdpat { $1 >>= \gdpats -> $2 >>= \gdpat -> return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } @@ -3147,9 +3167,9 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } | gdpats close {% runPV $1 >>= \ $1 -> return $ sL1 $1 ([],unLoc $1) } -gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) } +gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } : '|' guardquals '->' exp - { runExpCmdPV $4 >>= \ $4 -> + { runECP_PV $4 >>= \ $4 -> ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } @@ -3158,28 +3178,24 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) } -- Bangs inside are parsed as infix operator applications, so that -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } -pat : exp {% (checkPattern <=< runExpCmdP) $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - amms (checkPattern (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) +pat : exp {% (checkPattern <=< runECP_P) $1 } + | '!' aexp {% runECP_P $2 >>= \ $2 -> + amms (checkPattern (patBuilderBang (getLoc $1) $2)) [mj AnnBang $1] } bindpat :: { LPat GhcPs } -bindpat : exp {% runExpCmdP $1 >>= \ $1 -> - -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn - checkPattern_msg (text "Possibly caused by a missing 'do'?") $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn +bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn + checkPattern_msg (text "Possibly caused by a missing 'do'?") + (runECP_PV $1) } + | '!' aexp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn amms (checkPattern_msg (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (patBuilderBang (getLoc $1) `fmap` runECP_PV $2)) [mj AnnBang $1] } apat :: { LPat GhcPs } -apat : aexp {% (checkPattern <=< runExpCmdP) $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - amms (checkPattern - (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) +apat : aexp {% (checkPattern <=< runECP_P) $1 } + | '!' aexp {% runECP_P $2 >>= \ $2 -> + amms (checkPattern (patBuilderBang (getLoc $1) $2)) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -3189,7 +3205,7 @@ apats :: { [LPat GhcPs] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) } +stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } : '{' stmts '}' { $2 >>= \ $2 -> return $ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? @@ -3203,7 +3219,7 @@ stmtlist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) } +stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } : stmts ';' stmt { $1 >>= \ $1 -> $3 >>= \ $3 -> if null (snd $ unLoc $1) @@ -3236,17 +3252,17 @@ maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } : stmt {% runPV $1 } -stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } +stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) (mj AnnRec $1:(fst $ unLoc $2)) } -qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } - : bindpat '<-' exp { runExpCmdPV $3 >>= \ $3 -> +qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + : bindpat '<-' exp { runECP_PV $3 >>= \ $3 -> ams (sLL $1 $> $ mkBindStmt $1 $3) [mu AnnLarrow $2] } - | exp { runExpCmdPV $1 >>= \ $1 -> + | exp { runECP_PV $1 >>= \ $1 -> return $ sL1 $1 $ mkBodyStmt $1 } | 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2)) (mj AnnLet $1:(fst $ unLoc $2)) } @@ -3254,26 +3270,30 @@ qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } +fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } : fbinds1 { $1 } - | {- empty -} { ([],([], Nothing)) } + | {- empty -} { return ([],([], Nothing)) } -fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } +fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } : fbind ',' fbinds1 - {% addAnnotation (gl $1) AnnComma (gl $2) >> + { $1 >>= \ $1 -> + $3 >>= \ $3 -> + addAnnotation (gl $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } - | fbind { ([],([$1], Nothing)) } - | '..' { ([mj AnnDotdot $1],([], Just (getLoc $1))) } + | fbind { $1 >>= \ $1 -> + return ([],([$1], Nothing)) } + | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } -fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) } - : qvar '=' texp {% runExpCmdP $3 >>= \ $3 -> +fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } + : qvar '=' texp { runECP_PV $3 >>= \ $3 -> ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... - | qvar { sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True } + | qvar { placeHolderPunRhs >>= \rhs -> + return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -3291,7 +3311,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% runExpCmdP $3 >>= \ $3 -> +dbind : ipvar '=' exp {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (IPBind noExt (Left $1) $3)) [mj AnnEqual $2] } @@ -3505,18 +3525,18 @@ varop :: { Located RdrName } [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } -qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvarop { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } | hole_op { $1 } -qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvaropm { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } | hole_op { $1 } -hole_op :: { LHsExpr GhcPs } -- used in sections -hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt) +hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections +hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>)) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } @@ -3943,12 +3963,8 @@ hintExplicitForall tok = do where forallSymDoc = text (forallSym (isUnicode tok)) -checkIfBang :: LHsExpr GhcPs -> Bool -checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR -checkIfBang _ = False - -- | Warn about missing space after bang -warnSpaceAfterBang :: SrcSpan -> P () +warnSpaceAfterBang :: SrcSpan -> PV () warnSpaceAfterBang span = do bang_on <- getBit BangPatBit unless bang_on $ @@ -4048,7 +4064,7 @@ ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: HasSrcSpan a => P a -> [AddAnn] -> P a +amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a amms a bs = do { av@(dL->L l _) <- a ; addAnnsAt l bs ; return av } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f4b909b37a..8d15cb317b 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -13,8 +13,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module RdrHsSyn ( @@ -51,11 +49,11 @@ module RdrHsSyn ( -- Bunch of functions in the parser monad for -- checking and constructing values + checkExpBlockArguments, checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, - bang_RDR, isBangRdr, isTildeRdr, checkMonadComp, -- P (HsStmtContext RdrName) @@ -85,16 +83,19 @@ module RdrHsSyn ( warnStarIsType, failOpFewArgs, - SumOrTuple (..), mkSumOrTuple, + SumOrTuple (..), - -- Expression/command ambiguity resolution + -- Expression/command/pattern ambiguity resolution PV, runPV, - ExpCmdP(ExpCmdP, runExpCmdPV), - runExpCmdP, - ExpCmdI(..), - ecFromExp, - ecFromCmd, + ECP(ECP, runECP_PV), + runECP_P, + DisambInfixOp(..), + DisambECP(..), + ecpFromExp, + ecpFromCmd, + PatBuilder, + patBuilderBang, ) where @@ -911,7 +912,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" -checkRecordSyntax :: Outputable a => Located a -> P (Located a) +checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr@(dL->L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit unless allowed $ addError loc $ @@ -1056,117 +1057,80 @@ checkNoDocs msg ty = go ty -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs) +checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) -checkPattern_msg msg = runPV_msg msg . checkLPat +checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) -checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs) +checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(dL->L l _) = checkPat l e [] -checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] +checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args +checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ - patFail l e + patFail l (ppr e) checkPat loc e args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid -- non-bang-pattern parse of (C ! e) | Just (e', args') <- splitBang e = do { args'' <- mapM checkLPat args' ; checkPat loc e' (args'' ++ args) } -checkPat loc (dL->L _ (HsApp _ f e)) args +checkPat loc (dL->L _ (PatBuilderApp f e)) args = do p <- checkLPat e checkPat loc f (p : args) checkPat loc (dL->L _ e) [] = do p <- checkAPat loc e return (cL loc p) checkPat loc e _ - = patFail loc (unLoc e) + = patFail loc (ppr e) -checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs) +checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of - EWildPat _ -> return (WildPat noExt) - HsVar _ x -> return (VarPat noExt x) - HsLit _ (HsStringPrim _ _) -- (#13260) - -> addFatalError loc (text "Illegal unboxed string literal in pattern:" - $$ ppr e0) - - HsLit _ l -> return (LitPat noExt l) + PatBuilderPat p -> return p + PatBuilderVar x -> return (VarPat noExt x) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ - -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) + PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) - | bang == bang_RDR + PatBuilderBang lb e -- (! x) -> do { hintBangPat loc e0 ; e' <- checkLPat e ; addAnnotation loc AnnBang lb ; return (BangPat noExt e') } - ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt)) - EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n) - -- view pattern is well-formed if the pattern is - EViewPat _ expr patE -> checkLPat patE >>= - (return . (\p -> ViewPat noExt expr p)) - ExprWithTySig _ e t -> do e <- checkLPat e - return (SigPat noExt e t) - -- n+k patterns - OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) - (dL->L _ (HsVar _ (dL->L _ plus))) - (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + PatBuilderOpApp + (dL->L nloc (PatBuilderVar (dL->L _ n))) + (dL->L _ plus) + (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) - OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r - | isDataOcc (rdrNameOcc c) -> do + + PatBuilderOpApp l (dL->L cl c) r + | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r return (ConPatIn (cL cl c) (InfixCon l r)) - OpApp {} -> patFail loc e0 - - ExplicitList _ _ es -> do ps <- mapM checkLPat es - return (ListPat noExt ps) - - HsPar _ e -> checkLPat e >>= (return . (ParPat noExt)) - - ExplicitTuple _ es b - | all tupArgPresent es -> do ps <- mapM checkLPat - [e | (dL->L _ (Present _ e)) <- es] - return (TuplePat noExt ps b) - | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:" - $$ ppr e0) - - ExplicitSum _ alt arity expr -> do - p <- checkLPat expr - return (SumPat noExt p alt arity) - - RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } - -> do fs <- mapM checkPatField fs - return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE _ s | not (isTypedSplice s) - -> return (SplicePat noExt s) - _ -> patFail loc e0 + PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExt)) + _ -> patFail loc (ppr e0) -placeHolderPunRhs :: LHsExpr GhcPs +placeHolderPunRhs :: DisambECP b => PV (Located b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging -placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) +placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) -plus_RDR, bang_RDR, pun_RDR :: RdrName +plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack -bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") isBangRdr, isTildeRdr :: RdrName -> Bool @@ -1174,31 +1138,30 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" isBangRdr _ = False isTildeRdr = (==eqTyCon_RDR) -checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs) +checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (cL l (fld { hsRecFieldArg = p })) -patFail :: SrcSpan -> HsExpr GhcPs -> PV a +patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") - --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: SrcStrictness - -> LHsExpr GhcPs + -> Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkValDef _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind (cL (combineLocs lhs sig) - (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss + = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat + checkPatBind lhs' grhss checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -1206,14 +1169,16 @@ checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) Just (fun, is_infix, pats, ann) -> checkFunBind strictness ann (getLoc lhs) fun is_infix pats (cL l grhss) - Nothing -> checkPatBind lhs g } + Nothing -> do + lhs' <- checkPattern lhs + checkPatBind lhs' g } checkFunBind :: SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity - -> [LHsExpr GhcPs] + -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) @@ -1242,13 +1207,11 @@ makeFunBind fn ms fun_co_fn = idHsWrapper, fun_tick = [] } -checkPatBind :: LHsExpr GhcPs +checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind lhs (dL->L _ (_,grhss)) - = do { lhs <- checkPattern lhs - ; return ([],PatBind noExt lhs grhss - ([],[])) } + = return ([],PatBind noExt lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) @@ -1282,10 +1245,10 @@ checkValSigLhs lhs@(dL->L l _) default_RDR = mkUnqual varName (fsLit "default") pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse' +checkDoAndIfThenElse :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) => a -> Bool -> b -> Bool -> c -> PV () -checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit unless doAndIfThenElse $ do @@ -1303,20 +1266,21 @@ checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's -splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) +splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) - | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) +splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) + | isBangRdr (unLoc op) + = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) where - l' = combineLocs bang arg1 + l' = combineLocs op arg1 (arg1,argns) = split_bang r_arg [] - split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] -isFunLhs :: LHsExpr GhcPs - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) +isFunLhs :: Located (PatBuilder GhcPs) + -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1331,17 +1295,15 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (dL->L loc (HsVar _ (dL->L _ f))) es ann + go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann + go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) - (dL->L l (HsVar _ (L _ var))))) [] ann - | bang == bang_RDR - , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) + go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann + | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) -- For infix function defns, there should be only one infix *function* -- (though there may be infix *datacons* involved too). So we don't @@ -1356,7 +1318,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann + go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- getBit BangPatBit ; if bang_on then go e' (es' ++ es) ann @@ -1370,8 +1332,8 @@ isFunLhs e = go e [] [] Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = cL loc (OpApp noExt k - (cL loc' (HsVar noExt (cL loc' op))) r) + op_app = cL loc (PatBuilderOpApp k + (cL loc' op) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1856,7 +1818,7 @@ mergeDataCon all_xs = -- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- otherwise use the usual 'ListComp' context -checkMonadComp :: P (HsStmtContext Name) +checkMonadComp :: PV (HsStmtContext Name) checkMonadComp = do monadComprehensions <- getBit MonadComprehensionsBit return $ if monadComprehensions @@ -1864,96 +1826,373 @@ checkMonadComp = do else ListComp -- ------------------------------------------------------------------------- --- Expression/command ambiguity (arrow syntax). +-- Expression/command/pattern ambiguity. -- See Note [Ambiguous syntactic categories] -- --- ExpCmdP as defined is isomorphic to a pair of parsers: --- --- data ExpCmdP = ExpCmdP { expP :: PV (LHsExpr GhcPs) --- , cmdP :: PV (LHsCmd GhcPs) } --- -- See Note [Parser-Validator] -- See Note [Ambiguous syntactic categories] -newtype ExpCmdP = - ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) } +newtype ECP = + ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } -runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs)) -runExpCmdP p = runPV (runExpCmdPV p) +runECP_P :: DisambECP b => ECP -> P (Located b) +runECP_P p = runPV (runECP_PV p) -ecFromExp :: LHsExpr GhcPs -> ExpCmdP -ecFromExp a = ExpCmdP (ecFromExp' a) +ecpFromExp :: LHsExpr GhcPs -> ECP +ecpFromExp a = ECP (ecpFromExp' a) -ecFromCmd :: LHsCmd GhcPs -> ExpCmdP -ecFromCmd a = ExpCmdP (ecFromCmd' a) +ecpFromCmd :: LHsCmd GhcPs -> ECP +ecpFromCmd a = ECP (ecpFromCmd' a) +-- | Disambiguate infix operators. +-- See Note [Ambiguous syntactic categories] +class DisambInfixOp b where + checkIfBang :: b -> Bool + mkHsVarOpPV :: Located RdrName -> PV (Located b) + mkHsConOpPV :: Located RdrName -> PV (Located b) + mkHsInfixHolePV :: SrcSpan -> PV (Located b) + +instance p ~ GhcPs => DisambInfixOp (HsExpr p) where + checkIfBang (HsVar _ (unLoc -> op)) = isBangRdr op + checkIfBang _ = False + mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExt v) + mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExt v) + mkHsInfixHolePV l = return $ cL l hsHoleExpr + +instance DisambInfixOp RdrName where + checkIfBang = isBangRdr + mkHsConOpPV (dL->L l v) = return $ cL l v + mkHsVarOpPV (dL->L l v) = return $ cL l v + mkHsInfixHolePV l = + addFatalError l $ text "Invalid infix hole, expected an infix operator" + +-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are +-- parsing an expression, a command, or a pattern. -- See Note [Ambiguous syntactic categories] -class ExpCmdI b where +class b ~ (Body b) GhcPs => DisambECP b where + -- | See Note [Body in DisambECP] + type Body b :: * -> * -- | Return a command without ambiguity, or fail in a non-command context. - ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs)) + ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) -- | Return an expression without ambiguity, or fail in a non-expression context. - ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs)) + ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) -- | Disambiguate "\... -> ..." (lambda) - ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs + mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Disambiguate "let ... in ..." - ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs + mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) + -- | Infix operator representation + type InfixOp b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) -- | Disambiguate "f # x" (infix operator) - ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs + mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) -- | Disambiguate "case ... of ..." - ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) + -- | Function argument representation + type FunArg b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) -- | Disambiguate "f x" (function application) - ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs + mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) -- | Disambiguate "if ... then ... else ..." - ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> Located b + -> Bool -- semicolon? + -> Located b + -> PV (Located b) -- | Disambiguate "do { ... }" (do notation) - ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs + mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) -- | Disambiguate "( ... )" (parentheses) - ecHsPar :: Located (b GhcPs) -> b GhcPs - -- | Check if the argument requires -XBlockArguments. - checkBlockArguments :: Located (b GhcPs) -> PV () - -- | Check if -XDoAndIfThenElse is enabled. - checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs) - -> Bool -> Located (b GhcPs) -> PV () - -instance ExpCmdI HsCmd where - ecFromCmd' = return - ecFromExp' (dL-> L l e) = - addFatalError l $ - text "Parse error in command:" <+> ppr e - ecHsLam = HsCmdLam noExt - ecHsLet = HsCmdLet noExt - ecOpApp c1 op c2 = - let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in - HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] - ecHsCase = HsCmdCase noExt - ecHsApp = HsCmdApp noExt - ecHsIf = mkHsCmdIf - ecHsDo = HsCmdDo noExt - ecHsPar = HsCmdPar noExt - checkBlockArguments = checkCmdBlockArguments - checkDoAndIfThenElse = checkDoAndIfThenElse' - -instance ExpCmdI HsExpr where - ecFromCmd' (dL -> L l c) = do + mkHsParPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate a variable "f" or a data constructor "MkF". + mkHsVarPV :: Located RdrName -> PV (Located b) + -- | Disambiguate a monomorphic literal + mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) + -- | Disambiguate an overloaded literal + mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) + -- | Disambiguate a wildcard + mkHsWildCardPV :: SrcSpan -> PV (Located b) + -- | Disambiguate "a :: t" (type annotation) + mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + -- | Disambiguate "[a,b,c]" (list syntax) + mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) + -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) + mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) + -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) + mkHsRecordPV :: + SrcSpan -> + SrcSpan -> + Located b -> + ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> + PV (Located b) + -- | Disambiguate "-a" (negation) + mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate "(# a)" (right operator section) + mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) + -- | Disambiguate "(a -> b)" (view pattern) + mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) + -- | Disambiguate "a@b" (as-pattern) + mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) + -- | Disambiguate "~a" (lazy pattern) + mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate tuple sections and unboxed sums + mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) + +{- Note [UndecidableSuperClasses for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Assume we have a class C with an associated type T: + + class C a where + type T a + ... + +If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: + + {-# LANGUAGE UndecidableSuperClasses #-} + class C (T a) => C a where + type T a + ... + +Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes +making GHC loop. The workaround is to bring this constraint into scope +manually with a helper method: + + class C a where + type T a + superT :: (C (T a) => r) -> r + +In order to avoid ambiguous types, 'r' must mention 'a'. + +For consistency, we use this approach for all constraints on associated types, +even when -XUndecidableSuperClasses are not required. +-} + +{- Note [Body in DisambECP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that +require their argument to take a form of (body GhcPs) for some (body :: * -> +*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the +superclass constraints of DisambECP. + +The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop +this requirement. It is possible and would allow removing the type index of +PatBuilder, but leads to worse type inference, breaking some code in the +typechecker. +-} + +instance p ~ GhcPs => DisambECP (HsCmd p) where + type Body (HsCmd p) = HsCmd + ecpFromCmd' = return + ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) + mkHsLamPV l mg = return $ cL l (HsCmdLam noExt mg) + mkHsLetPV l bs e = return $ cL l (HsCmdLet noExt bs e) + type InfixOp (HsCmd p) = HsExpr p + superInfixOp m = m + mkHsOpAppPV l c1 op c2 = do + let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c + return $ cL l $ HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ cL l (HsCmdCase noExt c mg) + type FunArg (HsCmd p) = HsExpr p + superFunArg m = m + mkHsAppPV l c e = do + checkCmdBlockArguments c + checkExpBlockArguments e + return $ cL l (HsCmdApp noExt c e) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ cL l (mkHsCmdIf c a b) + mkHsDoPV l stmts = return $ cL l (HsCmdDo noExt stmts) + mkHsParPV l c = return $ cL l (HsCmdPar noExt c) + mkHsVarPV (dL->L l v) = cmdFail l (ppr v) + mkHsLitPV (dL->L l a) = cmdFail l (ppr a) + mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) + mkHsWildCardPV l = cmdFail l (text "_") + mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) + mkHsExplicitListPV l xs = cmdFail l $ + brackets (fsep (punctuate comma (map ppr xs))) + mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) + mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ + ppr a <+> ppr (mk_rec_fields fbinds ddLoc) + mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) + mkHsSectionR_PV l op c = cmdFail l $ + let pp_op = fromMaybe (panic "cannot print infix operator") + (ppr_infix_expr (unLoc op)) + in pp_op <> ppr c + mkHsViewPatPV l a b = cmdFail l $ + ppr a <+> text "->" <+> ppr b + mkHsAsPatPV l v c = cmdFail l $ + pprPrefixOcc (unLoc v) <> text "@" <> ppr c + mkHsLazyPatPV l c = cmdFail l $ + text "~" <> ppr c + mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) + +cmdFail :: SrcSpan -> SDoc -> PV a +cmdFail loc e = addFatalError loc $ + hang (text "Parse error in command:") 2 (ppr e) + +instance p ~ GhcPs => DisambECP (HsExpr p) where + type Body (HsExpr p) = HsExpr + ecpFromCmd' (dL -> L l c) = do addError l $ vcat [ text "Arrow command found where an expression was expected:", nest 2 (ppr c) ] return (cL l hsHoleExpr) - ecFromExp' = return - ecHsLam = HsLam noExt - ecHsLet = HsLet noExt - ecOpApp = OpApp noExt - ecHsCase = HsCase noExt - ecHsApp = HsApp noExt - ecHsIf = mkHsIf - ecHsDo = HsDo noExt DoExpr - ecHsPar = HsPar noExt - checkBlockArguments = checkExpBlockArguments - checkDoAndIfThenElse = checkDoAndIfThenElse' + ecpFromExp' = return + mkHsLamPV l mg = return $ cL l (HsLam noExt mg) + mkHsLetPV l bs c = return $ cL l (HsLet noExt bs c) + type InfixOp (HsExpr p) = HsExpr p + superInfixOp m = m + mkHsOpAppPV l e1 op e2 = do + return $ cL l $ OpApp noExt e1 op e2 + mkHsCasePV l e mg = return $ cL l (HsCase noExt e mg) + type FunArg (HsExpr p) = HsExpr p + superFunArg m = m + mkHsAppPV l e1 e2 = do + checkExpBlockArguments e1 + checkExpBlockArguments e2 + return $ cL l (HsApp noExt e1 e2) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ cL l (mkHsIf c a b) + mkHsDoPV l stmts = return $ cL l (HsDo noExt DoExpr stmts) + mkHsParPV l e = return $ cL l (HsPar noExt e) + mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExt v) + mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExt a) + mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExt a) + mkHsWildCardPV l = return $ cL l hsHoleExpr + mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExt a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExt Nothing xs) + mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExt) sp + mkHsRecordPV l lrec a (fbinds, ddLoc) = do + r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) + checkRecordSyntax (cL l r) + mkHsNegAppPV l a = return $ cL l (NegApp noExt a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ cL l (SectionR noExt op e) + mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty + mkHsAsPatPV l v e = do + opt_TypeApplications <- getBit TypeApplicationsBit + let msg | opt_TypeApplications + = "Type application syntax requires a space before '@'" + | otherwise + = "Did you mean to enable TypeApplications?" + patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) + mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty + mkSumOrTuplePV = mkSumOrTupleExpr + +patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) +patSynErr l e explanation = + do { addError l $ + sep [text "Pattern syntax in expression context:", + nest 4 (ppr e)] $$ + explanation + ; return (cL l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) +-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] +data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderBang SrcSpan (Located (PatBuilder p)) + | PatBuilderPar (Located (PatBuilder p)) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + | PatBuilderVar (Located RdrName) + | PatBuilderOverLit (HsOverLit GhcPs) + +patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) +patBuilderBang bang p = + cL (bang `combineSrcSpans` getLoc p) $ + PatBuilderBang bang p + +instance p ~ GhcPs => Outputable (PatBuilder p) where + ppr (PatBuilderPat p) = ppr p + ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p + ppr (PatBuilderPar (L _ p)) = parens (ppr p) + ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 + ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 + ppr (PatBuilderVar v) = ppr v + ppr (PatBuilderOverLit l) = ppr l + +instance p ~ GhcPs => DisambECP (PatBuilder p) where + type Body (PatBuilder p) = PatBuilder + ecpFromCmd' (dL-> L l c) = + addFatalError l $ + text "Command syntax in pattern:" <+> ppr c + ecpFromExp' (dL-> L l e) = + addFatalError l $ + text "Expression syntax in pattern:" <+> ppr e + mkHsLamPV l _ = addFatalError l $ + text "Lambda-syntax in pattern." $$ + text "Pattern matching on functions is not possible." + mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" + type InfixOp (PatBuilder p) = RdrName + superInfixOp m = m + mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2 + mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" + type FunArg (PatBuilder p) = PatBuilder p + superFunArg m = m + mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) + mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" + mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" + mkHsParPV l p = return $ cL l (PatBuilderPar p) + mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) + mkHsLitPV lit@(dL->L l a) = do + checkUnboxedStringLitPat lit + return $ cL l (PatBuilderPat (LitPat noExt a)) + mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExt)) + mkHsTySigPV l b sig = do + p <- checkLPat b + return $ cL l (PatBuilderPat (SigPat noExt p (mkLHsSigWcType sig))) + mkHsExplicitListPV l xs = do + ps <- traverse checkLPat xs + return (cL l (PatBuilderPat (ListPat noExt ps))) + mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExt sp)) + mkHsRecordPV l _ a (fbinds, ddLoc) = do + r <- mkPatRec a (mk_rec_fields fbinds ddLoc) + checkRecordSyntax (cL l r) + mkHsNegAppPV l (dL->L lp p) = do + lit <- case p of + PatBuilderOverLit pos_lit -> return (cL lp pos_lit) + _ -> patFail l (text "-" <> ppr p) + return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + mkHsSectionR_PV l op p + | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p + | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) + mkHsViewPatPV l a b = do + p <- checkLPat b + return $ cL l (PatBuilderPat (ViewPat noExt a p)) + mkHsAsPatPV l v e = do + p <- checkLPat e + return $ cL l (PatBuilderPat (AsPat noExt v p)) + mkHsLazyPatPV l e = do + p <- checkLPat e + return $ cL l (PatBuilderPat (LazyPat noExt p)) + mkSumOrTuplePV = mkSumOrTuplePat + +checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () +checkUnboxedStringLitPat (dL->L loc lit) = + case lit of + HsStringPrim _ _ -- Trac #13260 + -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) + _ -> return () + +mkPatRec :: + Located (PatBuilder GhcPs) -> + HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> + PV (PatBuilder GhcPs) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) + | isRdrDataCon (unLoc c) + = do fs <- mapM checkPatField fs + return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd)))) +mkPatRec p _ = + addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p + {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2008,9 +2247,19 @@ concerns local to the parser, and does not require duplication of hsSyn types, or an extra pass over the entire AST, is to parse into an overloaded parser-validator (a so-called tagless final encoding): - class ExpCmdI b where ... - instance ExpCmdI HsCmd where ... - instance ExpCmdI HsExp where ... + class DisambECP b where ... + instance p ~ GhcPs => DisambECP (HsCmd p) where ... + instance p ~ GhcPs => DisambECP (HsExp p) where ... + instance p ~ GhcPs => DisambECP (PatBuilder p) where ... + +The 'DisambECP' class contains functions to build and validate 'b'. For example, +to add parentheses we have: + + mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) + +'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for +expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, +see Note [PatBuilder]). Consider the 'alts' production used to parse case-of alternatives: @@ -2018,9 +2267,9 @@ Consider the 'alts' production used to parse case-of alternatives: : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } -We abstract over LHsExpr, and it becomes: +We abstract over LHsExpr GhcPs, and it becomes: - alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -2028,9 +2277,9 @@ We abstract over LHsExpr, and it becomes: Compared to the initial definition, the added bits are: - forall b. ExpCmdI b => PV ( ... ) -- in the type signature - $1 >>= \ $1 -> return $ -- in one reduction rule - $2 >>= \ $2 -> return $ -- in another reduction rule + forall b. DisambECP b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule The overhead is constant relative to the size of the rest of the reduction rule, so this approach scales well to large parser productions. @@ -2316,11 +2565,80 @@ thread 'tag' explicitly: | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } -This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to -more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities. +This encoding works well enough, but introduces an extra GADT unlike the +tagless final encoding, and there's no need for this complexity. -} +{- Note [PatBuilder] +~~~~~~~~~~~~~~~~~~~~ +Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, +so we introduce the notion of a PatBuilder. + +Consider a pattern like this: + + Con a b c + +We parse arguments to "Con" one at a time in the fexp aexp parser production, +building the result with mkHsAppPV, so the intermediate forms are: + + 1. Con + 2. Con a + 3. Con a b + 4. Con a b c + +In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like +this (pseudocode): + + 1. "Con" + 2. HsApp "Con" "a" + 3. HsApp (HsApp "Con" "a") "b" + 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" + +Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have +instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for +the intermediate forms. + +Worse yet, some intermediate forms are not valid patterns at all. For example: + + Con !a !b c + +This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then +rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid +patterns, so we cannot represent them as Pat. + +We also need an intermediate representation to postpone disambiguation between +FunBind and PatBind. Consider: + + a `Con` b = ... + a `fun` b = ... + +How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We +learn this by inspecting an intermediate representation in 'isFunLhs' and +seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate +representation capable of representing both a FunBind and a PatBind, so Pat is +insufficient. + +PatBuilder is an extension of Pat that is capable of representing intermediate +parsing results for patterns and function bindings: + + data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + ... + +It can represent any pattern via 'PatBuilderPat', but it also has a variety of +other constructors which were added by following a simple principle: we never +pattern match on the pattern stored inside 'PatBuilderPat'. + +For example, in 'splitBang' we need to match on space-separated and +bang-separated patterns, so these are represented with dedicated constructors +'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on +variables, so we have a dedicated 'PatBuilderVar' constructor for this despite +the existence of 'VarPat'. +-} + --------------------------------------------------------------------------- -- Miscellaneous utilities @@ -2342,7 +2660,7 @@ mkRecConstrOrUpdate :: LHsExpr GhcPs -> SrcSpan -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) - -> P (HsExpr GhcPs) + -> PV (HsExpr GhcPs) mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c @@ -2680,6 +2998,8 @@ localPV_msg f (PV m) = PV (local f m) instance MonadP PV where addError srcspan msg = PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg) + addWarning option srcspan msg = + PV $ ReaderT $ \_ -> addWarning option srcspan msg addFatalError srcspan msg = PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg) getBit ext = @@ -2762,35 +3082,67 @@ the error messages. -} -- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV () +hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ addFatalError span (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) -data SumOrTuple - = Sum ConTag Arity (LHsExpr GhcPs) - | Tuple [LHsTupArg GhcPs] +data SumOrTuple b + = Sum ConTag Arity (Located b) + | Tuple [Located (Maybe (Located b))] + +pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc +pprSumOrTuple boxity = \case + Sum alt arity e -> + parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> parClose + Tuple xs -> + parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) + <> parClose + where + ppr_bars n = hsep (replicate n (Outputable.char '|')) + (parOpen, parClose) = + case boxity of + Boxed -> (text "(", text ")") + Unboxed -> (text "(#", text "#)") -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) +mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) -- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) +mkSumOrTupleExpr l boxity (Tuple es) = + return $ cL l (ExplicitTuple noExt (map toTupArg es) boxity) + where + toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs + toTupArg = mapLoc (maybe missingTupArg (Present noExt)) -- Sum -mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum noExt alt arity e) -mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = +mkSumOrTupleExpr l Unboxed (Sum alt arity e) = + return $ cL l (ExplicitSum noExt alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 - (ppr_boxed_sum alt arity e)) + (pprSumOrTuple Boxed a)) + +mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) + +-- Tuple +mkSumOrTuplePat l boxity (Tuple ps) = do + ps' <- traverse toTupPat ps + return $ cL l (PatBuilderPat (TuplePat noExt ps' boxity)) where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc - ppr_boxed_sum alt arity e = - text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) - <+> text ")" + toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) + toTupPat (dL -> L l p) = case p of + Nothing -> addFatalError l (text "Tuple section in pattern context") + Just p' -> checkLPat p' - ppr_bars n = hsep (replicate n (Outputable.char '|')) +-- Sum +mkSumOrTuplePat l Unboxed (Sum alt arity p) = do + p' <- checkLPat p + return $ cL l (PatBuilderPat (SumPat noExt p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} = + addFatalError l (hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed a)) mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index dd38feb367..7b00a62403 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -140,6 +140,9 @@ rnExpr (HsVar _ (L l v)) rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) +rnExpr (HsUnboundVar x v) + = return (HsUnboundVar x v, emptyFVs) + rnExpr (HsOverLabel x _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on @@ -346,24 +349,6 @@ rnExpr (ArithSeq x _ seq) return (ArithSeq x Nothing new_seq, fvs) } {- -These three are pattern syntax appearing in expressions. -Since all the symbols are reservedops we can simply reject them. -We return a (bogus) EWildPat in each case. --} - -rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole -rnExpr e@(EAsPat {}) - = do { opt_TypeApplications <- xoptM LangExt.TypeApplications - ; let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - ; patSynErr e (text msg) - } -rnExpr e@(EViewPat {}) = patSynErr e empty -rnExpr e@(ELazyPat {}) = patSynErr e empty - -{- ************************************************************************ * * Static values @@ -415,9 +400,6 @@ rnExpr (HsProc x pat body) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) - ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -2087,12 +2069,6 @@ sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) -patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", - nest 4 (ppr e)] $$ - explanation) - ; return (EWildPat noExt, emptyFVs) } - badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds = hang (text "Implicit-parameter bindings illegal in" <+> what) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 2a2f05eea5..bc307568f8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3662,10 +3662,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e -exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat" -exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" -exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" -exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" diff --git a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr index 69839e3920..f50166fd41 100644 --- a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr +++ b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr @@ -1,4 +1,4 @@ -InfixAppPatErr.hs:2:3: error: - Parse error in pattern: f $ do a <- return 3 c +InfixAppPatErr.hs:2:7: error: + do-notation in pattern Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/T984.stderr b/testsuite/tests/parser/should_fail/T984.stderr index 4c723a7869..6d25a36e9e 100644 --- a/testsuite/tests/parser/should_fail/T984.stderr +++ b/testsuite/tests/parser/should_fail/T984.stderr @@ -1,4 +1,4 @@ -T984.hs:6:9: - Parse error in pattern: case () of { _ -> result } +T984.hs:6:9: error: + (case ... of ...)-syntax in pattern Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index aa089de3eb..2fc7f3d326 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -143,3 +143,21 @@ test('unpack_inside_type', normal, compile_fail, ['']) test('unpack_before_opr', normal, compile_fail, ['']) test('T16270', normal, compile_fail, ['']) test('T16270h', normal, compile_fail, ['']) +test('cmdFail001', normal, compile_fail, ['']) +test('cmdFail002', normal, compile_fail, ['']) +test('cmdFail003', normal, compile_fail, ['']) +test('cmdFail004', normal, compile_fail, ['']) +test('cmdFail005', normal, compile_fail, ['']) +test('cmdFail006', normal, compile_fail, ['']) +test('cmdFail007', normal, compile_fail, ['']) +test('cmdFail008', normal, compile_fail, ['']) +test('cmdFail009', normal, compile_fail, ['']) +test('patFail001', normal, compile_fail, ['']) +test('patFail002', normal, compile_fail, ['']) +test('patFail003', normal, compile_fail, ['']) +test('patFail004', normal, compile_fail, ['']) +test('patFail005', normal, compile_fail, ['']) +test('patFail006', normal, compile_fail, ['']) +test('patFail007', normal, compile_fail, ['']) +test('patFail008', normal, compile_fail, ['']) +test('patFail009', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_fail/cmdFail001.hs b/testsuite/tests/parser/should_fail/cmdFail001.hs new file mode 100644 index 0000000000..c5a4f2fc89 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail001.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail001 where + +f = proc x -> _ diff --git a/testsuite/tests/parser/should_fail/cmdFail001.stderr b/testsuite/tests/parser/should_fail/cmdFail001.stderr new file mode 100644 index 0000000000..7f8210ab4b --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail001.stderr @@ -0,0 +1,2 @@ + +cmdFail001.hs:4:15: error: Parse error in command: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail002.hs b/testsuite/tests/parser/should_fail/cmdFail002.hs new file mode 100644 index 0000000000..a75a4d249c --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail002.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail002 where + +f = proc x -> (_ -< _) :: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail002.stderr b/testsuite/tests/parser/should_fail/cmdFail002.stderr new file mode 100644 index 0000000000..1e0393346a --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail002.stderr @@ -0,0 +1,2 @@ + +cmdFail002.hs:4:15: error: Parse error in command: (_ -< _) :: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail003.hs b/testsuite/tests/parser/should_fail/cmdFail003.hs new file mode 100644 index 0000000000..03b8b823d3 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail003.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} +module CmdFail003 where + +f = proc x -> [_ -< _, + _ -< _, + _ -< _, + _ -< _, + _ -< _] diff --git a/testsuite/tests/parser/should_fail/cmdFail003.stderr b/testsuite/tests/parser/should_fail/cmdFail003.stderr new file mode 100644 index 0000000000..21f958174d --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail003.stderr @@ -0,0 +1,3 @@ + +cmdFail003.hs:4:15: error: + Parse error in command: [_ -< _, _ -< _, _ -< _, _ -< _, _ -< _] diff --git a/testsuite/tests/parser/should_fail/cmdFail004.hs b/testsuite/tests/parser/should_fail/cmdFail004.hs new file mode 100644 index 0000000000..89898cb983 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail004.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail004 where + +f = proc x -> (_ -> (_ -< _)) diff --git a/testsuite/tests/parser/should_fail/cmdFail004.stderr b/testsuite/tests/parser/should_fail/cmdFail004.stderr new file mode 100644 index 0000000000..ed14937367 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail004.stderr @@ -0,0 +1,2 @@ + +cmdFail004.hs:4:16: error: Parse error in command: _ -> (_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail005.hs b/testsuite/tests/parser/should_fail/cmdFail005.hs new file mode 100644 index 0000000000..a665ddd916 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail005.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail005 where + +f = proc x -> x@(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail005.stderr b/testsuite/tests/parser/should_fail/cmdFail005.stderr new file mode 100644 index 0000000000..9944ff277c --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail005.stderr @@ -0,0 +1,2 @@ + +cmdFail005.hs:4:15: error: Parse error in command: x@(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail006.hs b/testsuite/tests/parser/should_fail/cmdFail006.hs new file mode 100644 index 0000000000..5953d74170 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail006.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail006 where + +f = proc x -> ~(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail006.stderr b/testsuite/tests/parser/should_fail/cmdFail006.stderr new file mode 100644 index 0000000000..ad64e91648 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail006.stderr @@ -0,0 +1,2 @@ + +cmdFail006.hs:4:15: error: Parse error in command: ~(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail007.hs b/testsuite/tests/parser/should_fail/cmdFail007.hs new file mode 100644 index 0000000000..1d3c3adc17 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail007.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Arrows #-} +module CmdFail007 where + +f = proc x -> + (_ -< _) { a = _ -< _, + b = _ -< _, + c = _ -< _ } diff --git a/testsuite/tests/parser/should_fail/cmdFail007.stderr b/testsuite/tests/parser/should_fail/cmdFail007.stderr new file mode 100644 index 0000000000..82dadb6b67 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail007.stderr @@ -0,0 +1,4 @@ + +cmdFail007.hs:5:7: error: + Parse error in command: + (_ -< _) {a = _ -< _, b = _ -< _, c = _ -< _} diff --git a/testsuite/tests/parser/should_fail/cmdFail008.hs b/testsuite/tests/parser/should_fail/cmdFail008.hs new file mode 100644 index 0000000000..76e9864a9d --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail008.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail008 where + +f = proc x -> (! (_ -< _)) diff --git a/testsuite/tests/parser/should_fail/cmdFail008.stderr b/testsuite/tests/parser/should_fail/cmdFail008.stderr new file mode 100644 index 0000000000..0f2f0818d7 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail008.stderr @@ -0,0 +1,2 @@ + +cmdFail008.hs:4:16: error: Parse error in command: !(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail009.hs b/testsuite/tests/parser/should_fail/cmdFail009.hs new file mode 100644 index 0000000000..e61ba08189 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail009.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} +module CmdFail009 where + +f = proc x -> (_ -< _, + _ -< _, + _ -< _, + _ -< _, + _ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail009.stderr b/testsuite/tests/parser/should_fail/cmdFail009.stderr new file mode 100644 index 0000000000..a0c4af5b77 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail009.stderr @@ -0,0 +1,3 @@ + +cmdFail009.hs:4:15: error: + Parse error in command: (_ -< _,_ -< _,_ -< _,_ -< _,_ -< _) diff --git a/testsuite/tests/parser/should_fail/patFail001.hs b/testsuite/tests/parser/should_fail/patFail001.hs new file mode 100644 index 0000000000..1e41ed25fe --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail001.hs @@ -0,0 +1,3 @@ +module PatFail001 where + +f (\x -> a) = _ diff --git a/testsuite/tests/parser/should_fail/patFail001.stderr b/testsuite/tests/parser/should_fail/patFail001.stderr new file mode 100644 index 0000000000..6dd20d794d --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail001.stderr @@ -0,0 +1,4 @@ + +patFail001.hs:3:4: error: + Lambda-syntax in pattern. + Pattern matching on functions is not possible. diff --git a/testsuite/tests/parser/should_fail/patFail002.hs b/testsuite/tests/parser/should_fail/patFail002.hs new file mode 100644 index 0000000000..b6be3c4482 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail002.hs @@ -0,0 +1,3 @@ +module PatFail002 where + +f (let a = x in a) = _ diff --git a/testsuite/tests/parser/should_fail/patFail002.stderr b/testsuite/tests/parser/should_fail/patFail002.stderr new file mode 100644 index 0000000000..804bfe9f47 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail002.stderr @@ -0,0 +1,2 @@ + +patFail002.hs:3:4: error: (let ... in ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail003.hs b/testsuite/tests/parser/should_fail/patFail003.hs new file mode 100644 index 0000000000..aab9750ee8 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail003.hs @@ -0,0 +1,3 @@ +module PatFail003 where + +f (case x of a -> b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail003.stderr b/testsuite/tests/parser/should_fail/patFail003.stderr new file mode 100644 index 0000000000..dc6e7aaea0 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail003.stderr @@ -0,0 +1,2 @@ + +patFail003.hs:3:4: error: (case ... of ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail004.hs b/testsuite/tests/parser/should_fail/patFail004.hs new file mode 100644 index 0000000000..0bc1ada01e --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail004.hs @@ -0,0 +1,3 @@ +module PatFail004 where + +f (if c then a else b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail004.stderr b/testsuite/tests/parser/should_fail/patFail004.stderr new file mode 100644 index 0000000000..48d289c348 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail004.stderr @@ -0,0 +1,3 @@ + +patFail004.hs:3:4: error: + (if ... then ... else ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail005.hs b/testsuite/tests/parser/should_fail/patFail005.hs new file mode 100644 index 0000000000..b140752fe9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail005.hs @@ -0,0 +1,3 @@ +module PatFail005 where + +f (do a; b; c) = _ diff --git a/testsuite/tests/parser/should_fail/patFail005.stderr b/testsuite/tests/parser/should_fail/patFail005.stderr new file mode 100644 index 0000000000..1302d62e0c --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail005.stderr @@ -0,0 +1,2 @@ + +patFail005.hs:3:4: error: do-notation in pattern diff --git a/testsuite/tests/parser/should_fail/patFail006.hs b/testsuite/tests/parser/should_fail/patFail006.hs new file mode 100644 index 0000000000..ede9ad3a01 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail006.hs @@ -0,0 +1,3 @@ +module PatFail006 where + +f (-(1)) = _ diff --git a/testsuite/tests/parser/should_fail/patFail006.stderr b/testsuite/tests/parser/should_fail/patFail006.stderr new file mode 100644 index 0000000000..270f738163 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail006.stderr @@ -0,0 +1,2 @@ + +patFail006.hs:3:4: error: Parse error in pattern: -(1) diff --git a/testsuite/tests/parser/should_fail/patFail007.hs b/testsuite/tests/parser/should_fail/patFail007.hs new file mode 100644 index 0000000000..fb6a48d4d8 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail007.hs @@ -0,0 +1,3 @@ +module PatFail007 where + +f (+1) = _ diff --git a/testsuite/tests/parser/should_fail/patFail007.stderr b/testsuite/tests/parser/should_fail/patFail007.stderr new file mode 100644 index 0000000000..f07689ba83 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail007.stderr @@ -0,0 +1,2 @@ + +patFail007.hs:3:4: error: Parse error in pattern: +1 diff --git a/testsuite/tests/parser/should_fail/patFail008.hs b/testsuite/tests/parser/should_fail/patFail008.hs new file mode 100644 index 0000000000..a4b5a3b98e --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail008.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module PatFail008 where + +f (a -< b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail008.stderr b/testsuite/tests/parser/should_fail/patFail008.stderr new file mode 100644 index 0000000000..d9957d9ca5 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail008.stderr @@ -0,0 +1,2 @@ + +patFail008.hs:4:4: error: Command syntax in pattern: a -< b diff --git a/testsuite/tests/parser/should_fail/patFail009.hs b/testsuite/tests/parser/should_fail/patFail009.hs new file mode 100644 index 0000000000..53e54a7d58 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail009.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} +module PatFail009 where + +f #a = _ diff --git a/testsuite/tests/parser/should_fail/patFail009.stderr b/testsuite/tests/parser/should_fail/patFail009.stderr new file mode 100644 index 0000000000..0c9fb5de15 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail009.stderr @@ -0,0 +1,2 @@ + +patFail009.hs:4:3: error: Expression syntax in pattern: #a |