Merge remote branch 'origin/master'
[ghc.git] / compiler / typecheck / TcArrows.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 Typecheck arrow notation
6
7 \begin{code}
8 module TcArrows ( tcProc ) where
9
10 import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
11
12 import HsSyn
13 import TcMatches
14 import TcType
15 import TcMType
16 import TcBinds
17 import TcPat
18 import TcUnify
19 import TcRnMonad
20 import TcEnv
21 import Coercion
22 import Id( mkLocalId )
23 import Inst
24 import Name
25 import TysWiredIn
26 import VarSet 
27 import TysPrim
28
29 import SrcLoc
30 import Outputable
31 import FastString
32 import Util
33
34 import Control.Monad
35 \end{code}
36
37 %************************************************************************
38 %*                                                                      *
39                 Proc    
40 %*                                                                      *
41 %************************************************************************
42
43 \begin{code}
44 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
45        -> TcRhoType                             -- Expected type of whole proc expression
46        -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion)
47
48 tcProc pat cmd exp_ty
49   = newArrowScope $
50     do  { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
51         ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
52         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
53         ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
54                           tcCmdTop cmd_env cmd [] res_ty
55         ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty))
56         ; return (pat', cmd', res_coi) }
57 \end{code}
58
59
60 %************************************************************************
61 %*                                                                      *
62                 Commands
63 %*                                                                      *
64 %************************************************************************
65
66 \begin{code}
67 type CmdStack = [TcTauType]
68 data CmdEnv
69   = CmdEnv {
70         cmd_arr         :: TcType -- arrow type constructor, of kind *->*->*
71     }
72
73 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
74 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
75
76 ---------------------------------------
77 tcCmdTop :: CmdEnv 
78          -> LHsCmdTop Name
79          -> CmdStack
80          -> TcTauType   -- Expected result type; always a monotype
81                              -- We know exactly how many cmd args are expected,
82                              -- albeit perhaps not their types; so we can pass 
83                              -- in a CmdStack
84         -> TcM (LHsCmdTop TcId)
85
86 tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
87   = setSrcSpan loc $
88     do  { cmd'   <- tcCmd env cmd (cmd_stk, res_ty)
89         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
90         ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
91
92
93 ----------------------------------------
94 tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
95         -- The main recursive function
96 tcCmd env (L loc expr) res_ty
97   = setSrcSpan loc $ do
98         { expr' <- tc_cmd env expr res_ty
99         ; return (L loc expr') }
100
101 tc_cmd :: CmdEnv -> HsExpr Name -> (CmdStack, TcTauType) -> TcM (HsExpr TcId)
102 tc_cmd env (HsPar cmd) res_ty
103   = do  { cmd' <- tcCmd env cmd res_ty
104         ; return (HsPar cmd') }
105
106 tc_cmd env (HsLet binds (L body_loc body)) res_ty
107   = do  { (binds', body') <- tcLocalBinds binds         $
108                              setSrcSpan body_loc        $
109                              tc_cmd env body res_ty
110         ; return (HsLet binds' (L body_loc body')) }
111
112 tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
113   = addErrCtxt (cmdCtxt in_cmd) $ do
114       (scrut', scrut_ty) <- tcInferRho scrut 
115       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
116       return (HsCase scrut' matches')
117   where
118     match_ctxt = MC { mc_what = CaseAlt,
119                       mc_body = mc_body }
120     mc_body body res_ty' = tcCmd env body (stk, res_ty')
121
122 tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
123   = do  { pred_ty <- newFlexiTyVarTy openTypeKind
124         ; b_ty <- newFlexiTyVarTy openTypeKind
125         ; let if_ty = mkFunTys [pred_ty, b_ty, b_ty] res_ty
126         ; mb_fun' <- case mb_fun of 
127               Nothing  -> return Nothing
128               Just fun -> liftM Just (tcSyntaxOp IfOrigin fun if_ty)
129         ; pred' <- tcMonoExpr pred pred_ty
130         ; b1'   <- tcCmd env b1 (stack_ty,b_ty)
131         ; b2'   <- tcCmd env b2 (stack_ty,b_ty)
132         ; return (HsIf mb_fun' pred' b1' b2')
133     }
134
135 -------------------------------------------
136 --              Arrow application
137 --          (f -< a)   or   (f -<< a)
138
139 tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
140   = addErrCtxt (cmdCtxt cmd)    $
141     do  { arg_ty <- newFlexiTyVarTy openTypeKind
142         ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
143
144         ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
145
146         ; arg' <- tcMonoExpr arg arg_ty
147
148         ; return (HsArrApp fun' arg' fun_ty ho_app lr) }
149   where
150         -- Before type-checking f, use the environment of the enclosing
151         -- proc for the (-<) case.  
152         -- Local bindings, inside the enclosing proc, are not in scope 
153         -- inside f.  In the higher-order case (-<<), they are.
154     select_arrow_scope tc = case ho_app of
155         HsHigherOrderApp -> tc
156         HsFirstOrderApp  -> escapeArrowScope tc
157
158 -------------------------------------------
159 --              Command application
160
161 tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
162   = addErrCtxt (cmdCtxt cmd)    $
163     do  { arg_ty <- newFlexiTyVarTy openTypeKind
164
165         ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
166
167         ; arg' <- tcMonoExpr arg arg_ty
168
169         ; return (HsApp fun' arg') }
170
171 -------------------------------------------
172 --              Lambda
173
174 tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _))
175        (cmd_stk, res_ty)
176   = addErrCtxt (pprMatchInCtxt match_ctxt match)        $
177
178     do  {       -- Check the cmd stack is big enough
179         ; checkTc (lengthAtLeast cmd_stk n_pats)
180                   (kappaUnderflow cmd)
181
182                 -- Check the patterns, and the GRHSs inside
183         ; (pats', grhss') <- setSrcSpan mtch_loc                $
184                              tcPats LambdaExpr pats cmd_stk     $
185                              tc_grhss grhss res_ty
186
187         ; let match' = L mtch_loc (Match pats' Nothing grhss')
188         ; return (HsLam (MatchGroup [match'] res_ty))
189         }
190
191   where
192     n_pats     = length pats
193     stk'       = drop n_pats cmd_stk
194     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
195     pg_ctxt    = PatGuard match_ctxt
196
197     tc_grhss (GRHSs grhss binds) res_ty
198         = do { (binds', grhss') <- tcLocalBinds binds $
199                                    mapM (wrapLocM (tc_grhs res_ty)) grhss
200              ; return (GRHSs grhss' binds') }
201
202     tc_grhs res_ty (GRHS guards body)
203         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
204                                   \ res_ty -> tcCmd env body (stk', res_ty)
205              ; return (GRHS guards' rhs') }
206
207 -------------------------------------------
208 --              Do notation
209
210 tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
211   = do  { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
212         ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty 
213         ; return (HsDo do_or_lc stmts' res_ty) }
214   where
215
216
217 -----------------------------------------------------------------
218 --      Arrow ``forms''       (| e c1 .. cn |)
219 --
220 --      G      |-b  c : [s1 .. sm] s
221 --      pop(G) |-   e : forall w. b ((w,s1) .. sm) s
222 --                              -> a ((w,t1) .. tn) t
223 --      e \not\in (s, s1..sm, t, t1..tn)
224 --      ----------------------------------------------
225 --      G |-a  (| e c |)  :  [t1 .. tn] t
226
227 tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)       
228   = addErrCtxt (cmdCtxt cmd)    $
229     do  { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
230         ; [w_tv]     <- tcInstSkolTyVars [alphaTyVar]
231         ; let w_ty = mkTyVarTy w_tv     -- Just a convenient starting point
232
233                 --  a ((w,t1) .. tn) t
234         ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
235
236                 --   b ((w,s1) .. sm) s
237                 --   -> a ((w,t1) .. tn) t
238         ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] 
239                               e_res_ty
240
241                 -- Check expr
242         ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
243                                  escapeArrowScope (tcMonoExpr expr e_ty)
244
245                 -- OK, now we are in a position to unscramble 
246                 -- the s1..sm and check each cmd
247         ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
248
249         ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds
250         ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') }
251   where
252         -- Make the types       
253         --      b, ((e,s1) .. sm), s
254     new_cmd_ty :: LHsCmdTop Name -> Int
255                -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
256     new_cmd_ty cmd i
257           = do  { b_ty   <- newFlexiTyVarTy arrowTyConKind
258                 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
259                         -- We actually make a type variable for the tuple
260                         -- because we don't know how deeply nested it is yet    
261                 ; s_ty   <- newFlexiTyVarTy liftedTypeKind
262                 ; return (cmd, i, b_ty, tup_ty, s_ty)
263                 }
264
265     tc_cmd w_tv (cmd, i, b, tup_ty, s)
266       = do { tup_ty' <- zonkTcType tup_ty
267            ; let (corner_ty, arg_tys) = unscramble tup_ty'
268
269                 -- Check that it has the right shape:
270                 --      ((w,s1) .. sn)
271                 -- where the si do not mention w
272            ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && 
273                       not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
274                      (badFormFun i tup_ty')
275
276            ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
277
278     unscramble :: TcType -> (TcType, [TcType])
279     -- unscramble ((w,s1) .. sn)        =  (w, [s1..sn])
280     unscramble ty = unscramble' ty []
281
282     unscramble' ty ss
283        = case tcSplitTyConApp_maybe ty of
284             Just (tc, [t,s]) | tc == pairTyCon 
285                ->  unscramble' t (s:ss)
286             _ -> (ty, ss)
287
288 -----------------------------------------------------------------
289 --              Base case for illegal commands
290 -- This is where expressions that aren't commands get rejected
291
292 tc_cmd _ cmd _
293   = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), 
294                       ptext (sLit "was found where an arrow command was expected")])
295 \end{code}
296
297
298 %************************************************************************
299 %*                                                                      *
300                 Stmts
301 %*                                                                      *
302 %************************************************************************
303
304 \begin{code}
305 --------------------------------
306 --      Mdo-notation
307 -- The distinctive features here are
308 --      (a) RecStmts, and
309 --      (b) no rebindable syntax
310
311 tcArrDoStmt :: CmdEnv -> TcStmtChecker
312 tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
313   = do  { rhs' <- tcCmd env rhs ([], res_ty)
314         ; thing <- thing_inside (panic "tcArrDoStmt")
315         ; return (LastStmt rhs' noSyntaxExpr, thing) }
316
317 tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside
318   = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
319         ; thing          <- thing_inside res_ty
320         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
321
322 tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
323   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
324         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
325                             thing_inside res_ty
326         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
327
328 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
329                             , recS_rec_ids = recNames }) res_ty thing_inside
330   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
331         ; let rec_ids = zipWith mkLocalId recNames rec_tys
332         ; tcExtendIdEnv rec_ids $ do
333         { (stmts', (later_ids, rec_rets))
334                 <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
335                         -- ToDo: res_ty not really right
336                    do { rec_rets <- zipWithM tcCheckId recNames rec_tys
337                       ; later_ids <- tcLookupLocalIds laterNames
338                       ; return (later_ids, rec_rets) }
339
340         ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
341                 -- NB:  The rec_ids for the recursive things 
342                 --      already scope over this part. This binding may shadow
343                 --      some of them with polymorphic things with the same Name
344                 --      (see note [RecStmt] in HsExpr)
345
346         ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
347                                , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
348                                , recS_ret_ty = res_ty }, thing)
349         }}
350
351 tcArrDoStmt _ _ stmt _ _
352   = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
353
354 tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType)
355 tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
356                         ; rhs' <- tcCmd env rhs ([], ty)
357                         ; return (rhs', ty) }
358 \end{code}
359
360
361 %************************************************************************
362 %*                                                                      *
363                 Helpers
364 %*                                                                      *
365 %************************************************************************
366
367
368 \begin{code}
369 mkPairTy :: Type -> Type -> Type
370 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
371
372 arrowTyConKind :: Kind          --  *->*->*
373 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
374 \end{code}
375
376
377 %************************************************************************
378 %*                                                                      *
379                 Errors
380 %*                                                                      *
381 %************************************************************************
382
383 \begin{code}
384 cmdCtxt :: HsExpr Name -> SDoc
385 cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
386
387 nonEmptyCmdStkErr :: HsExpr Name -> SDoc
388 nonEmptyCmdStkErr cmd
389   = hang (ptext (sLit "Non-empty command stack at command:"))
390        2 (ppr cmd)
391
392 kappaUnderflow :: HsExpr Name -> SDoc
393 kappaUnderflow cmd
394   = hang (ptext (sLit "Command stack underflow at command:"))
395        2 (ppr cmd)
396
397 badFormFun :: Int -> TcType -> SDoc
398 badFormFun i tup_ty'
399  = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape"))
400       2 (ptext (sLit "Argument type:") <+> ppr tup_ty')
401 \end{code}