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