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 {-# OPTIONS -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
13 -- for details
14
15 module TcArrows ( tcProc ) where
16
17 import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
18
19 import HsSyn
20 import TcMatches
21 import TcHsSyn( hsLPatType )
22 import TcType
23 import TcMType
24 import TcBinds
25 import TcPat
26 import TcUnify
27 import TcRnMonad
28 import TcEnv
29 import TcEvidence
30 import Id( mkLocalId )
31 import Inst
32 import Name
33 import TysWiredIn
34 import VarSet 
35 import TysPrim
36
37 import SrcLoc
38 import Outputable
39 import FastString
40 import Util
41
42 import Control.Monad
43 \end{code}
44
45 %************************************************************************
46 %*                                                                      *
47                 Proc    
48 %*                                                                      *
49 %************************************************************************
50
51 \begin{code}
52 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
53        -> TcRhoType                             -- Expected type of whole proc expression
54        -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)
55
56 tcProc pat cmd exp_ty
57   = newArrowScope $
58     do  { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
59         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
60         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
61         ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
62                           tcCmdTop cmd_env cmd [] res_ty
63         ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcReflCo res_ty))
64         ; return (pat', cmd', res_co) }
65 \end{code}
66
67
68 %************************************************************************
69 %*                                                                      *
70                 Commands
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 type CmdStack = [TcTauType]
76 data CmdEnv
77   = CmdEnv {
78         cmd_arr         :: TcType -- arrow type constructor, of kind *->*->*
79     }
80
81 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
82 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
83
84 ---------------------------------------
85 tcCmdTop :: CmdEnv 
86          -> LHsCmdTop Name
87          -> CmdStack
88          -> TcTauType   -- Expected result type; always a monotype
89                              -- We know exactly how many cmd args are expected,
90                              -- albeit perhaps not their types; so we can pass 
91                              -- in a CmdStack
92         -> TcM (LHsCmdTop TcId)
93
94 tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
95   = setSrcSpan loc $
96     do  { cmd'   <- tcCmd env cmd (cmd_stk, res_ty)
97         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
98         ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
99
100
101 ----------------------------------------
102 tcCmd  :: CmdEnv -> LHsCmd Name -> (CmdStack, TcTauType) -> TcM (LHsCmd TcId)
103         -- The main recursive function
104 tcCmd env (L loc cmd) res_ty
105   = setSrcSpan loc $ do
106         { cmd' <- tc_cmd env cmd res_ty
107         ; return (L loc cmd') }
108
109 tc_cmd :: CmdEnv -> HsCmd Name  -> (CmdStack, TcTauType) -> TcM (HsCmd TcId)
110 tc_cmd env (HsCmdPar cmd) res_ty
111   = do  { cmd' <- tcCmd env cmd res_ty
112         ; return (HsCmdPar cmd') }
113
114 tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty
115   = do  { (binds', body') <- tcLocalBinds binds         $
116                              setSrcSpan body_loc        $
117                              tc_cmd env body res_ty
118         ; return (HsCmdLet binds' (L body_loc body')) }
119
120 tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
121   = addErrCtxt (cmdCtxt in_cmd) $ do
122       (scrut', scrut_ty) <- tcInferRho scrut 
123       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
124       return (HsCmdCase scrut' matches')
125   where
126     match_ctxt = MC { mc_what = CaseAlt,
127                       mc_body = mc_body }
128     mc_body body res_ty' = tcCmd env body (stk, res_ty')
129
130 tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
131   = do  { pred' <- tcMonoExpr pred boolTy
132         ; b1'   <- tcCmd env b1 res_ty
133         ; b2'   <- tcCmd env b2 res_ty
134         ; return (HsCmdIf Nothing pred' b1' b2')
135     }
136
137 tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
138   = do  { pred_ty <- newFlexiTyVarTy openTypeKind
139         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
140         -- because we're going to apply it to the environment, not
141         -- the return value.
142         ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
143         ; let r_ty = mkTyVarTy r_tv
144         ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty
145         ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty))
146                   (ptext (sLit "Predicate type of `ifThenElse' depends on result type"))
147         ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
148         ; pred' <- tcMonoExpr pred pred_ty
149         ; b1'   <- tcCmd env b1 res_ty
150         ; b2'   <- tcCmd env b2 res_ty
151         ; return (HsCmdIf (Just fun') pred' b1' b2')
152     }
153
154 -------------------------------------------
155 --              Arrow application
156 --          (f -< a)   or   (f -<< a)
157
158 tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
159   = addErrCtxt (cmdCtxt cmd)    $
160     do  { arg_ty <- newFlexiTyVarTy openTypeKind
161         ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
162
163         ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
164              -- ToDo: There should be no need for the escapeArrowScope stuff
165              -- See Note [Escaping the arrow scope] in TcRnTypes
166
167         ; arg' <- tcMonoExpr arg arg_ty
168
169         ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
170   where
171        -- Before type-checking f, use the environment of the enclosing
172        -- proc for the (-<) case.  
173        -- Local bindings, inside the enclosing proc, are not in scope 
174        -- inside f.  In the higher-order case (-<<), they are.
175     select_arrow_scope tc = case ho_app of
176         HsHigherOrderApp -> tc
177         HsFirstOrderApp  -> escapeArrowScope tc
178
179 -------------------------------------------
180 --              Command application
181
182 tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
183   = addErrCtxt (cmdCtxt cmd)    $
184     do  { arg_ty <- newFlexiTyVarTy openTypeKind
185
186         ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
187
188         ; arg' <- tcMonoExpr arg arg_ty
189
190         ; return (HsCmdApp fun' arg') }
191
192 -------------------------------------------
193 --              Lambda
194
195 tc_cmd env cmd@(HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] }))
196        (cmd_stk, res_ty)
197   = addErrCtxt (pprMatchInCtxt match_ctxt match)        $
198
199     do  {       -- Check the cmd stack is big enough
200         ; checkTc (lengthAtLeast cmd_stk n_pats)
201                   (kappaUnderflow cmd)
202
203                 -- Check the patterns, and the GRHSs inside
204         ; (pats', grhss') <- setSrcSpan mtch_loc                $
205                              tcPats LambdaExpr pats cmd_stk     $
206                              tc_grhss grhss res_ty
207
208         ; let match' = L mtch_loc (Match pats' Nothing grhss')
209               arg_tys = map hsLPatType pats'
210         ; return (HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
211                                , mg_res_ty = res_ty }))
212               -- Or should we decompose res_ty?
213         }
214
215   where
216     n_pats     = length pats
217     stk'       = drop n_pats cmd_stk
218     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
219     pg_ctxt    = PatGuard match_ctxt
220
221     tc_grhss (GRHSs grhss binds) res_ty
222         = do { (binds', grhss') <- tcLocalBinds binds $
223                                    mapM (wrapLocM (tc_grhs res_ty)) grhss
224              ; return (GRHSs grhss' binds') }
225
226     tc_grhs res_ty (GRHS guards body)
227         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
228                                   \ res_ty -> tcCmd env body (stk', res_ty)
229              ; return (GRHS guards' rhs') }
230
231 -------------------------------------------
232 --              Do notation
233
234 tc_cmd env cmd@(HsCmdDo stmts _) (cmd_stk, res_ty)
235   = do  { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
236         ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty 
237         ; return (HsCmdDo stmts' res_ty) }
238   where
239
240
241 -----------------------------------------------------------------
242 --      Arrow ``forms''       (| e c1 .. cn |)
243 --
244 --      G      |-b  c : [s1 .. sm] s
245 --      pop(G) |-   e : forall w. b ((w,s1) .. sm) s
246 --                              -> a ((w,t1) .. tn) t
247 --      e \not\in (s, s1..sm, t, t1..tn)
248 --      ----------------------------------------------
249 --      G |-a  (| e c |)  :  [t1 .. tn] t
250
251 tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)    
252   = addErrCtxt (cmdCtxt cmd)    $
253     do  { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
254         ; (_, [w_tv])     <- tcInstSkolTyVars [alphaTyVar]
255         ; let w_ty = mkTyVarTy w_tv     -- Just a convenient starting point
256
257                 --  a ((w,t1) .. tn) t
258         ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
259
260                 --   b ((w,s1) .. sm) s
261                 --   -> a ((w,t1) .. tn) t
262         ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] 
263                               e_res_ty
264
265   -- ToDo: SLPJ: something is badly wrong here.  
266   -- The escapeArrowScope pops the Untouchables.. but that
267   -- risks screwing up the skolem-escape check
268   -- Moreover, arrowfail001 fails with an ASSERT failure
269   -- because a variable gets the wrong level
270                 -- Check expr
271         ; (inner_binds, expr')
272                <- checkConstraints ArrowSkol [w_tv] [] $
273                   escapeArrowScope (tcMonoExpr expr e_ty)
274
275 {-
276         ; ((inner_binds, expr'), lie)
277                <- captureConstraints $
278                   checkConstraints ArrowSkol [w_tv] [] $
279                   tcMonoExpr expr e_ty
280                                  -- No need for escapeArrowScope in the 
281                                  -- type checker.
282                                  -- Note [Escaping the arrow scope] in TcRnTypes
283         ; (lie, outer_binds) <- solveWantedsTcM lie
284         ; emitConstraints lie
285 -}
286
287                 -- OK, now we are in a position to unscramble 
288                 -- the s1..sm and check each cmd
289         ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
290
291         ; let wrap = WpTyLam w_tv <.> mkWpLet inner_binds
292         ; return (HsCmdArrForm (mkLHsWrap wrap expr') fixity cmds') }
293   where
294         -- Make the types       
295         --      b, ((e,s1) .. sm), s
296     new_cmd_ty :: LHsCmdTop Name -> Int
297                -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
298     new_cmd_ty cmd i
299           = do  { b_ty   <- newFlexiTyVarTy arrowTyConKind
300                 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
301                         -- We actually make a type variable for the tuple
302                         -- because we don't know how deeply nested it is yet    
303                 ; s_ty   <- newFlexiTyVarTy liftedTypeKind
304                 ; return (cmd, i, b_ty, tup_ty, s_ty)
305                 }
306
307     tc_cmd w_tv (cmd, i, b, tup_ty, s)
308       = do { tup_ty' <- zonkTcType tup_ty
309            ; let (corner_ty, arg_tys) = unscramble tup_ty'
310
311                 -- Check that it has the right shape:
312                 --      ((w,s1) .. sn)
313                 -- where the si do not mention w
314            ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv)
315            ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
316                      (badFormFun i tup_ty')
317      -- JPM: WARNING: this test is utterly bogus; see #5609
318      -- We are not using the coercion returned by the unify;
319      -- and (even more seriously) the w not in arg_tys test is totally
320      -- bogus if there are suspended equality constraints. This code
321      -- needs to be re-architected.
322
323            ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
324
325     unscramble :: TcType -> (TcType, [TcType])
326     -- unscramble ((w,s1) .. sn)        =  (w, [s1..sn])
327     unscramble ty = unscramble' ty []
328
329     unscramble' ty ss
330        = case tcSplitTyConApp_maybe ty of
331             Just (tc, [t,s]) | tc == pairTyCon 
332                ->  unscramble' t (s:ss)
333             _ -> (ty, ss)
334
335 -----------------------------------------------------------------
336 --              Base case for illegal commands
337 -- This is where expressions that aren't commands get rejected
338
339 tc_cmd _ cmd _
340   = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), 
341                       ptext (sLit "was found where an arrow command was expected")])
342 \end{code}
343
344
345 %************************************************************************
346 %*                                                                      *
347                 Stmts
348 %*                                                                      *
349 %************************************************************************
350
351 \begin{code}
352 --------------------------------
353 --      Mdo-notation
354 -- The distinctive features here are
355 --      (a) RecStmts, and
356 --      (b) no rebindable syntax
357
358 tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
359 tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
360   = do  { rhs' <- tcCmd env rhs ([], res_ty)
361         ; thing <- thing_inside (panic "tcArrDoStmt")
362         ; return (LastStmt rhs' noSyntaxExpr, thing) }
363
364 tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside
365   = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
366         ; thing          <- thing_inside res_ty
367         ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
368
369 tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
370   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
371         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
372                             thing_inside res_ty
373         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
374
375 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
376                             , recS_rec_ids = rec_names }) res_ty thing_inside
377   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
378         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
379         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
380         ; tcExtendIdEnv tup_ids $ do
381         { (stmts', tup_rets)
382                 <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
383                         -- ToDo: res_ty not really right
384                    zipWithM tcCheckId tup_names tup_elt_tys
385
386         ; thing <- thing_inside res_ty
387                 -- NB:  The rec_ids for the recursive things 
388                 --      already scope over this part. This binding may shadow
389                 --      some of them with polymorphic things with the same Name
390                 --      (see note [RecStmt] in HsExpr)
391
392         ; let rec_ids = takeList rec_names tup_ids
393         ; later_ids <- tcLookupLocalIds later_names
394
395         ; let rec_rets = takeList rec_names tup_rets
396         ; let ret_table = zip tup_ids tup_rets
397         ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
398
399         ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
400                                , recS_later_rets = later_rets
401                                , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
402                                , recS_ret_ty = res_ty }, thing)
403         }}
404
405 tcArrDoStmt _ _ stmt _ _
406   = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
407
408 tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType)
409 tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
410                         ; rhs' <- tcCmd env rhs ([], ty)
411                         ; return (rhs', ty) }
412 \end{code}
413
414
415 %************************************************************************
416 %*                                                                      *
417                 Helpers
418 %*                                                                      *
419 %************************************************************************
420
421
422 \begin{code}
423 mkPairTy :: Type -> Type -> Type
424 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
425
426 arrowTyConKind :: Kind          --  *->*->*
427 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
428 \end{code}
429
430
431 %************************************************************************
432 %*                                                                      *
433                 Errors
434 %*                                                                      *
435 %************************************************************************
436
437 \begin{code}
438 cmdCtxt :: HsCmd Name -> SDoc
439 cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
440
441 nonEmptyCmdStkErr :: HsCmd Name -> SDoc
442 nonEmptyCmdStkErr cmd
443   = hang (ptext (sLit "Non-empty command stack at command:"))
444        2 (ppr cmd)
445
446 kappaUnderflow :: HsCmd Name -> SDoc
447 kappaUnderflow cmd
448   = hang (ptext (sLit "Command stack underflow at command:"))
449        2 (ppr cmd)
450
451 badFormFun :: Int -> TcType -> SDoc
452 badFormFun i tup_ty'
453  = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape"))
454       2 (ptext (sLit "Argument type:") <+> ppr tup_ty')
455 \end{code}