2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcGRHSs]{Typecheck guarded right-hand-sides}
7 module TcGRHSs ( tcGRHSsAndBinds, tcStmt ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcExpr( tcExpr )
13 import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..),
17 import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
18 import TcHsSyn ( TcGRHSsAndBinds, TcGRHS, TcStmt )
21 import Inst ( Inst, LIE, plusLIE )
22 import TcBinds ( tcBindsAndThen )
23 import TcPat ( tcPat )
24 import TcType ( TcType, newTyVarTy )
25 import TcEnv ( newMonoIds )
26 import TysWiredIn ( boolTy )
27 import Kind ( mkTypeKind, mkBoxedTypeKind )
32 %************************************************************************
36 %************************************************************************
39 tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
41 tcGRHSs expected_ty [grhs]
42 = tcGRHS expected_ty grhs `thenTc` \ (grhs', lie) ->
43 returnTc ([grhs'], lie)
45 tcGRHSs expected_ty (grhs:grhss)
46 = tcGRHS expected_ty grhs `thenTc` \ (grhs', lie1) ->
47 tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie2) ->
48 returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
50 tcGRHS expected_ty (GRHS guard expr locn)
52 tcStmts guard `thenTc` \ ((guard', expr'), lie) ->
53 returnTc (GRHS guard' expr' locn, lie)
55 tcStmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) ->
56 returnTc (([], expr2), expr_lie)
57 tcStmts (stmt:stmts) = tcStmt Guard (\x->x) combine stmt $
60 combine stmt _ (stmts, expr) = (stmt:stmts, expr)
64 %************************************************************************
66 \subsection{GRHSsAndBinds}
68 %************************************************************************
70 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
74 tcGRHSsAndBinds :: TcType s -- Expected type of RHSs
75 -> RenamedGRHSsAndBinds
76 -> TcM s (TcGRHSsAndBinds s, LIE s)
78 -- Shortcut for common case
79 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss EmptyBinds)
80 = tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie) ->
81 returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
83 tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
86 (tcGRHSs expected_ty grhss)
88 combiner is_rec binds grhss
89 = GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
93 %************************************************************************
95 \subsection{Record bindings}
97 %************************************************************************
101 tcStmt :: DoOrListComp
102 -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
103 -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
105 -> TcM s (thing, LIE s)
106 -> TcM s (thing, LIE s)
108 tcStmt do_or_lc m combine stmt@(ReturnStmt exp) do_next
109 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
110 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
111 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
112 tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
113 returnTc (ReturnStmt exp', exp_lie, m exp_ty)
114 ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
115 do_next `thenTc` \ (thing', thing_lie) ->
116 returnTc (combine stmt' (Just stmt_ty) thing',
117 stmt_lie `plusLIE` thing_lie)
119 tcStmt do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
120 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
121 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
122 tcAddSrcLoc src_loc (
123 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
124 tcExpr exp boolTy `thenTc` \ (exp', exp_lie) ->
125 returnTc (GuardStmt exp' src_loc, exp_lie)
126 )) `thenTc` \ (stmt', stmt_lie) ->
127 do_next `thenTc` \ (thing', thing_lie) ->
128 returnTc (combine stmt' Nothing thing',
129 stmt_lie `plusLIE` thing_lie)
131 tcStmt do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
132 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
133 newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
134 tcAddSrcLoc src_loc (
135 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
136 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
138 -- exp has type (m tau) for some tau (doesn't matter what)
141 tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
142 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
143 )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
144 do_next `thenTc` \ (thing', thing_lie) ->
145 returnTc (combine stmt' (Just stmt_ty) thing',
146 stmt_lie `plusLIE` thing_lie)
148 tcStmt do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
149 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
150 tcAddSrcLoc src_loc (
151 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
152 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
153 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
155 -- NB: the environment has been extended with the new binders
156 -- which the rhs can't "see", but the renamer should have made
157 -- sure that everything is distinct by now, so there's no problem.
158 -- Putting the tcExpr before the newMonoIds messes up the nesting
159 -- of error contexts, so I didn't bother
161 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
162 )) `thenTc` \ (stmt', stmt_lie) ->
163 do_next `thenTc` \ (thing', thing_lie) ->
164 returnTc (combine stmt' Nothing thing',
165 stmt_lie `plusLIE` thing_lie)
167 tcStmt do_or_lc m combine (LetStmt binds) do_next
168 = tcBindsAndThen -- No error context, but a binding group is
169 combine' -- rather a large thing for an error context anyway
173 combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
176 stmtCtxt do_or_lc stmt
177 = hang (ptext SLIT("In a") <+> whatever <> colon)
180 whatever = case do_or_lc of
181 ListComp -> ptext SLIT("list-comprehension qualifier")
182 DoStmt -> ptext SLIT("do statement")
183 Guard -> ptext SLIT("guard")