Commit 7905ea41 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-10-12 13:29:12 by simonpj]

Small refactoring
parent 1be10360
...@@ -42,7 +42,7 @@ import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys ...@@ -42,7 +42,7 @@ import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys
dataConFieldLabels, dataConSourceArity, dataConSig ) dataConFieldLabels, dataConSourceArity, dataConSig )
import PrelNames ( integralClassName ) import PrelNames ( integralClassName )
import BasicTypes ( isBoxed ) import BasicTypes ( isBoxed )
import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc ) import SrcLoc ( Located(..), SrcSpan, noLoc )
import Maybes ( catMaybes ) import Maybes ( catMaybes )
import ErrUtils ( Message ) import ErrUtils ( Message )
import Outputable import Outputable
...@@ -75,13 +75,21 @@ tcPat :: PatCtxt ...@@ -75,13 +75,21 @@ tcPat :: PatCtxt
[TcTyVar], -- Existential binders [TcTyVar], -- Existential binders
a) -- Result of thing inside a) -- Result of thing inside
tcPat ctxt pat exp_ty thing_inside tcPat ctxt (L span pat) exp_ty thing_inside
= do { err_ctxt <- getErrCtxt = do { -- Restore error context before doing thing_inside
; maybeAddErrCtxt (patCtxt (unLoc pat)) $ -- See note [Nesting] above
tc_lpat ctxt pat exp_ty $ err_ctxt <- getErrCtxt
setErrCtxt err_ctxt thing_inside } ; let real_thing_inside = setErrCtxt err_ctxt thing_inside
-- Restore error context before doing thing_inside
-- See note [Nesting] above -- It's OK to keep setting the SrcSpan;
-- it just overwrites the previous value
; (pat', tvs, res) <- setSrcSpan span $
maybeAddErrCtxt (patCtxt pat) $
tc_pat ctxt pat exp_ty $
real_thing_inside
; return (L span pat', tvs, res)
}
-------------------- --------------------
tcPats :: PatCtxt tcPats :: PatCtxt
...@@ -167,21 +175,13 @@ bindInstsOfPatId id thing_inside ...@@ -167,21 +175,13 @@ bindInstsOfPatId id thing_inside
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
tc_lpat :: PatCtxt tc_pat :: PatCtxt
-> LPat Name -> Expected TcSigmaType -> Pat Name -> Expected TcSigmaType
-> TcM a -- Thing inside -> TcM a -- Thing inside
-> TcM (LPat TcId, -- Translated pattern -> TcM (Pat TcId, -- Translated pattern
[TcTyVar], -- Existential binders [TcTyVar], -- Existential binders
a) -- Result of thing inside a) -- Result of thing inside
tc_lpat ctxt (L span pat) pat_ty thing_inside
= setSrcSpan span $
-- It's OK to keep setting the SrcSpan;
-- it just overwrites the previous value
do { (pat', tvs, res) <- tc_pat ctxt pat pat_ty thing_inside
; return (L span pat', tvs, res) }
---------------------
tc_pat ctxt (VarPat name) pat_ty thing_inside tc_pat ctxt (VarPat name) pat_ty thing_inside
= do { id <- tcPatBndr ctxt name pat_ty = do { id <- tcPatBndr ctxt name pat_ty
; (res, binds) <- bindInstsOfPatId id $ ; (res, binds) <- bindInstsOfPatId id $
...@@ -193,7 +193,7 @@ tc_pat ctxt (VarPat name) pat_ty thing_inside ...@@ -193,7 +193,7 @@ tc_pat ctxt (VarPat name) pat_ty thing_inside
; return (pat', [], res) } ; return (pat', [], res) }
tc_pat ctxt (ParPat pat) pat_ty thing_inside tc_pat ctxt (ParPat pat) pat_ty thing_inside
= do { (pat', tvs, res) <- tc_lpat ctxt pat pat_ty thing_inside = do { (pat', tvs, res) <- tcPat ctxt pat pat_ty thing_inside
; return (ParPat pat', tvs, res) } ; return (ParPat pat', tvs, res) }
-- There's a wrinkle with irrefuatable patterns, namely that we -- There's a wrinkle with irrefuatable patterns, namely that we
...@@ -208,7 +208,7 @@ tc_pat ctxt (ParPat pat) pat_ty thing_inside ...@@ -208,7 +208,7 @@ tc_pat ctxt (ParPat pat) pat_ty thing_inside
-- because they won't be in scope when we do the desugaring -- because they won't be in scope when we do the desugaring
tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside
= do { reft <- getTypeRefinement = do { reft <- getTypeRefinement
; (pat', pat_tvs, res) <- tc_lpat ctxt pat pat_ty $ ; (pat', pat_tvs, res) <- tcPat ctxt pat pat_ty $
setTypeRefinement reft thing_inside setTypeRefinement reft thing_inside
; if (null pat_tvs) then return () ; if (null pat_tvs) then return ()
else lazyPatErr lpat pat_tvs else lazyPatErr lpat pat_tvs
...@@ -229,7 +229,7 @@ tc_pat ctxt (WildPat _) pat_ty thing_inside ...@@ -229,7 +229,7 @@ tc_pat ctxt (WildPat _) pat_ty thing_inside
tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty) = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $ ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
tc_lpat ctxt pat (Check (idType bndr_id)) thing_inside tcPat ctxt pat (Check (idType bndr_id)) thing_inside
-- NB: if we do inference on: -- NB: if we do inference on:
-- \ (y@(x::forall a. a->a)) = e -- \ (y@(x::forall a. a->a)) = e
-- we'll fail. The as-pattern infers a monotype for 'y', which then -- we'll fail. The as-pattern infers a monotype for 'y', which then
...@@ -248,7 +248,7 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside ...@@ -248,7 +248,7 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
sig_ty' = substTy subst sig_ty sig_ty' = substTy subst sig_ty
; (pat', tvs, res) ; (pat', tvs, res)
<- tcExtendTyVarEnv2 tv_binds $ <- tcExtendTyVarEnv2 tv_binds $
tc_lpat ctxt pat (Check sig_ty') thing_inside tcPat ctxt pat (Check sig_ty') thing_inside
; return (SigPatOut pat' sig_ty, tvs, res) } ; return (SigPatOut pat' sig_ty, tvs, res) }
...@@ -362,6 +362,7 @@ tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside ...@@ -362,6 +362,7 @@ tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside
| otherwise -- GADT case | otherwise -- GADT case
= do { let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con = do { let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con
; traceTc (text "tcConPat: GADT" <+> ppr data_con)
; span <- getSrcSpanM ; span <- getSrcSpanM
; let rigid_info = PatSkol data_con span ; let rigid_info = PatSkol data_con span
; tvs' <- tcSkolTyVars rigid_info tvs ; tvs' <- tcSkolTyVars rigid_info tvs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment