From 0ff152c9e633accca48815e26e59d1af1fe44ceb Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 5 Nov 2017 21:49:11 +0200 Subject: WIP on combining Step 1 and 3 of Trees That Grow See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow Trees that grow extension points are added for - ValBinds - HsPat - HsLit - HsOverLit - HsType - HsTyVarBndr - HsAppType - FieldOcc - AmbiguousFieldOcc Updates haddock submodule Test Plan: ./validate Reviewers: shayan-najd, simonpj, austin, goldfire, bgamari Subscribers: goldfire, rwbarton, thomie, mpickering Differential Revision: https://phabricator.haskell.org/D4147 --- compiler/typecheck/TcPat.hs | 78 ++++++++++++++++++++++++--------------------- 1 file changed, 42 insertions(+), 36 deletions(-) (limited to 'compiler/typecheck/TcPat.hs') diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index c5e367e3be..7c3872c78b 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -324,21 +324,21 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat (L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } -tc_pat penv (ParPat pat) pat_ty thing_inside +tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat pat', res) } + ; return (ParPat x pat', res) } -tc_pat penv (BangPat pat) pat_ty thing_inside +tc_pat penv (BangPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat pat', res) } + ; return (BangPat x pat', res) } -tc_pat penv (LazyPat pat) pat_ty thing_inside +tc_pat penv (LazyPat x pat) pat_ty thing_inside = do { (pat', (res, pat_ct)) <- tc_lpat pat pat_ty (makeLazy penv) $ captureConstraints thing_inside @@ -352,14 +352,14 @@ tc_pat penv (LazyPat pat) pat_ty thing_inside ; pat_ty <- readExpType pat_ty ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind - ; return (LazyPat pat', res) } + ; return (LazyPat x pat', res) } tc_pat _ (WildPat _) pat_ty thing_inside = do { res <- thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -372,9 +372,10 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, + res) } -tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside +tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside = do { -- Expr must have type `forall a1...aN. OPT' -> B` -- where overall_pat_ty is an instance of OPT'. @@ -401,30 +402,31 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- (overall_pat_ty -> inf_res_ty) expr_wrap = expr_wrap2' <.> expr_wrap1 doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } + ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} -- Type signatures in patterns -- See Note [Pattern coercions] below -tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside +tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty ; (pat', res) <- tcExtendTyVarEnv2 wcs $ tcExtendTyVarEnv2 tv_binds $ tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } + ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) } ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside +tc_pat penv (ListPat Nothing pats) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + ; return (mkHsWrapPat coi + (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } -tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside +tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside = do { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] @@ -433,18 +435,18 @@ tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; return (pats', res, elt_ty) } - ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res) + ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) } -tc_pat penv (PArrPat pats _) pat_ty thing_inside +tc_pat penv (PArrPat _ pats ) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) + ; return (mkHsWrapPat coi (PArrPat elt_ty pats') pat_ty, res) } -tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside +tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside = do { let arity = length pats tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) @@ -463,19 +465,19 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- This is a pretty odd place to make the switch, but -- it was easy to do. ; let - unmangled_result = TuplePat pats' boxity con_arg_tys + unmangled_result = TuplePat con_arg_tys pats' boxity -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat (noLoc unmangled_result) - | otherwise = unmangled_result + isBoxed boxity = LazyPat noExt (noLoc unmangled_result) + | otherwise = unmangled_result ; pat_ty <- readExpType pat_ty ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } -tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside +tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside = do { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv pat_ty @@ -484,7 +486,8 @@ tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res) + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) } ------------------------ @@ -494,12 +497,12 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside ------------------------ -- Literal patterns -tc_pat penv (LitPat simple_lit) pat_ty thing_inside +tc_pat penv (LitPat x simple_lit) pat_ty thing_inside = do { let lit_ty = hsLitType simple_lit ; wrap <- tcSubTypePat penv pat_ty lit_ty ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty , res) } ------------------------ @@ -520,7 +523,7 @@ tc_pat penv (LitPat simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -538,7 +541,7 @@ tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -569,7 +572,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside +tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty + thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit ; (lit1', ge') @@ -598,15 +602,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' pat_ty + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' ; return (pat', res) } -- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat))) +tc_pat penv (SplicePat _ (HsSpliced mod_finalizers (HsSplicedPat pat))) pat_ty thing_inside = do addModFinalizersWithLclEnv mod_finalizers tc_pat penv pat pat_ty thing_inside @@ -982,14 +986,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat' + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } + tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ + = panic "tcConArgs" find_field_ty :: Name -> FieldLabelString -> TcM TcType find_field_ty sel lbl -- cgit v1.2.1