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 -w #-}
   9 -- The above warning supression flag is a temporary kludge.
  10 -- While working on this module you are encouraged to remove it and fix
  11 -- any warnings in the module. See
  12 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  13 -- for details
  14
  15 module TcArrows ( tcProc ) where
  16
  17 #include "HsVersions.h"
  18
  19 import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho )
  20
  21 import HsSyn
  22 import TcHsSyn
  23
  24 import TcMatches
  25
  26 import TcType
  27 import TcMType
  28 import TcBinds
  29 import TcSimplify
  30 import TcGadt
  31 import TcPat
  32 import TcUnify
  33 import TcRnMonad
  34 import Inst
  35 import Name
  36 import TysWiredIn
  37 import VarSet
  38 import TysPrim
  39 import Type
  40
  41 import SrcLoc
  42 import Outputable
  43 import Util
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48                 Proc
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 \begin{code}
  53 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
  54        -> BoxyRhoType                           -- Expected type of whole proc expression
  55        -> TcM (OutPat TcId, LHsCmdTop TcId)
  56
  57 tcProc pat cmd exp_ty
  58   = newArrowScope $
  59     do  { (exp_ty1, res_ty) <- boxySplitAppTy exp_ty
  60         ; (arr_ty, arg_ty)  <- boxySplitAppTy exp_ty1
  61         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
  62         ; (pat', cmd') <- tcLamPat pat arg_ty (emptyRefinement, res_ty) $
  63                           tcCmdTop cmd_env cmd []
  64         ; return (pat', cmd') }
  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          -> (Refinement, 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 reft_res_ty@(_,res_ty)
  95   = setSrcSpan loc $
  96     do  { cmd'   <- tcGuardedCmd env cmd cmd_stk reft_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 tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
 103              -> (Refinement, TcTauType) -> TcM (LHsExpr TcId)
 104 -- A wrapper that deals with the refinement (if any)
 105 tcGuardedCmd env expr stk (reft, res_ty)
 106   = do  { let (co, res_ty') = refineResType reft res_ty
 107         ; body <- tcCmd env expr (stk, res_ty')
 108         ; return (mkLHsWrap co body) }
 109
 110 tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
 111         -- The main recursive function
 112 tcCmd env (L loc expr) res_ty
 113   = setSrcSpan loc $ do
 114         { expr' <- tc_cmd env expr res_ty
 115         ; return (L loc expr') }
 116
 117 tc_cmd env (HsPar cmd) res_ty
 118   = do  { cmd' <- tcCmd env cmd res_ty
 119         ; return (HsPar cmd') }
 120
 121 tc_cmd env (HsLet binds (L body_loc body)) res_ty
 122   = do  { (binds', body') <- tcLocalBinds binds         $
 123                              setSrcSpan body_loc        $
 124                              tc_cmd env body res_ty
 125         ; return (HsLet binds' (L body_loc body')) }
 126
 127 tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
 128   = addErrCtxt (cmdCtxt in_cmd)         $
 129     addErrCtxt (caseScrutCtxt scrut)    (
 130       tcInferRho scrut
 131     )                                                   `thenM` \ (scrut', scrut_ty) ->
 132     tcMatchesCase match_ctxt scrut_ty matches res_ty    `thenM` \ matches' ->
 133     returnM (HsCase scrut' matches')
 134   where
 135     match_ctxt = MC { mc_what = CaseAlt,
 136                       mc_body = mc_body }
 137     mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
 138
 139 tc_cmd env (HsIf pred b1 b2) res_ty
 140   = do  { pred' <- tcMonoExpr pred boolTy
 141         ; b1'   <- tcCmd env b1 res_ty
 142         ; b2'   <- tcCmd env b2 res_ty
 143         ; return (HsIf pred' b1' b2')
 144     }
 145
 146 -------------------------------------------
 147 --              Arrow application
 148 --          (f -< a)   or   (f -<< a)
 149
 150 tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
 151   = addErrCtxt (cmdCtxt cmd)    $
 152     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 153         ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
 154
 155         ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
 156
 157         ; arg' <- tcMonoExpr arg arg_ty
 158
 159         ; return (HsArrApp fun' arg' fun_ty ho_app lr) }
 160   where
 161         -- Before type-checking f, use the environment of the enclosing
 162         -- proc for the (-<) case.
 163         -- Local bindings, inside the enclosing proc, are not in scope
 164         -- inside f.  In the higher-order case (-<<), they are.
 165     select_arrow_scope tc = case ho_app of
 166         HsHigherOrderApp -> tc
 167         HsFirstOrderApp  -> escapeArrowScope tc
 168
 169 -------------------------------------------
 170 --              Command application
 171
 172 tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
 173   = addErrCtxt (cmdCtxt cmd)    $
 174 -- gaw 2004 FIX?
 175     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 176
 177         ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
 178
 179         ; arg' <- tcMonoExpr arg arg_ty
 180
 181         ; return (HsApp fun' arg') }
 182
 183 -------------------------------------------
 184 --              Lambda
 185
 186 tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _))
 187        (cmd_stk, res_ty)
 188   = addErrCtxt (matchCtxt match_ctxt match)     $
 189
 190     do  {       -- Check the cmd stack is big enough
 191         ; checkTc (lengthAtLeast cmd_stk n_pats)
 192                   (kappaUnderflow cmd)
 193
 194                 -- Check the patterns, and the GRHSs inside
 195         ; (pats', grhss') <- setSrcSpan mtch_loc                $
 196                              tcLamPats pats cmd_stk res_ty      $
 197                              tc_grhss grhss
 198
 199         ; let match' = L mtch_loc (Match pats' Nothing grhss')
 200         ; return (HsLam (MatchGroup [match'] res_ty))
 201         }
 202
 203   where
 204     n_pats     = length pats
 205     stk'       = drop n_pats cmd_stk
 206     match_ctxt = LambdaExpr     -- Maybe KappaExpr?
 207     pg_ctxt    = PatGuard match_ctxt
 208
 209     tc_grhss (GRHSs grhss binds) res_ty
 210         = do { (binds', grhss') <- tcLocalBinds binds $
 211                                    mapM (wrapLocM (tc_grhs res_ty)) grhss
 212              ; return (GRHSs grhss' binds') }
 213
 214     tc_grhs res_ty (GRHS guards body)
 215         = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
 216                                   tcGuardedCmd env body stk'
 217              ; return (GRHS guards' rhs') }
 218
 219 -------------------------------------------
 220 --              Do notation
 221
 222 tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
 223   = do  { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
 224         ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts (emptyRefinement, res_ty) $
 225                              tcGuardedCmd env body []
 226         ; return (HsDo do_or_lc stmts' body' res_ty) }
 227   where
 228     tc_stmt = tcMDoStmt tc_rhs
 229     tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
 230                     ; rhs' <- tcCmd env rhs ([], ty)
 231                     ; return (rhs', ty) }
 232
 233
 234 -----------------------------------------------------------------
 235 --      Arrow ``forms''       (| e c1 .. cn |)
 236 --
 237 --      G      |-b  c : [s1 .. sm] s
 238 --      pop(G) |-   e : forall w. b ((w,s1) .. sm) s
 239 --                              -> a ((w,t1) .. tn) t
 240 --      e \not\in (s, s1..sm, t, t1..tn)
 241 --      ----------------------------------------------
 242 --      G |-a  (| e c |)  :  [t1 .. tn] t
 243
 244 tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 245   = addErrCtxt (cmdCtxt cmd)    $
 246     do  { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
 247         ; span       <- getSrcSpanM
 248         ; [w_tv]     <- tcInstSkolTyVars ArrowSkol [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         ; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty))
 261         ; loc <- getInstLoc (SigOrigin ArrowSkol)
 262         ; inst_binds <- tcSimplifyCheck loc [w_tv] [] lie
 263
 264                 -- Check that the polymorphic variable hasn't been unified with anything
 265                 -- and is not free in res_ty or the cmd_stk  (i.e.  t, t1..tn)
 266         ; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv]
 267
 268                 -- OK, now we are in a position to unscramble
 269                 -- the s1..sm and check each cmd
 270         ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
 271
 272         ; returnM (HsArrForm (noLoc $ HsWrap (WpTyLam w_tv)
 273                                                (unLoc $ mkHsDictLet inst_binds expr'))
 274                              fixity cmds')
 275         }
 276   where
 277         -- Make the types
 278         --      b, ((e,s1) .. sm), s
 279     new_cmd_ty :: LHsCmdTop Name -> Int
 280                -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
 281     new_cmd_ty cmd i
 282           = do  { b_ty   <- newFlexiTyVarTy arrowTyConKind
 283                 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
 284                         -- We actually make a type variable for the tuple
 285                         -- because we don't know how deeply nested it is yet
 286                 ; s_ty   <- newFlexiTyVarTy liftedTypeKind
 287                 ; return (cmd, i, b_ty, tup_ty, s_ty)
 288                 }
 289
 290     tc_cmd w_tv (cmd, i, b, tup_ty, s)
 291       = do { tup_ty' <- zonkTcType tup_ty
 292            ; let (corner_ty, arg_tys) = unscramble tup_ty'
 293
 294                 -- Check that it has the right shape:
 295                 --      ((w,s1) .. sn)
 296                 -- where the si do not mention w
 297            ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv &&
 298                       not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
 299                      (badFormFun i tup_ty')
 300
 301            ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys (emptyRefinement, s) }
 302
 303     unscramble :: TcType -> (TcType, [TcType])
 304     -- unscramble ((w,s1) .. sn)        =  (w, [s1..sn])
 305     unscramble ty
 306        = case tcSplitTyConApp_maybe ty of
 307             Just (tc, [t,s]) | tc == pairTyCon
 308                ->  let
 309                       (w,ss) = unscramble t
 310                    in (w, s:ss)
 311
 312             other -> (ty, [])
 313
 314 -----------------------------------------------------------------
 315 --              Base case for illegal commands
 316 -- This is where expressions that aren't commands get rejected
 317
 318 tc_cmd env cmd _
 319   = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd),
 320                       ptext SLIT("was found where an arrow command was expected")])
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326                 Helpers
 327 %*                                                                      *
 328 %************************************************************************
 329
 330
 331 \begin{code}
 332 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
 333
 334 arrowTyConKind :: Kind          --  *->*->*
 335 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
 336 \end{code}
 337
 338
 339 %************************************************************************
 340 %*                                                                      *
 341                 Errors
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 \begin{code}
 346 cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd
 347
 348 caseScrutCtxt cmd
 349   = hang (ptext SLIT("In the scrutinee of a case command:")) 4 (ppr cmd)
 350
 351 nonEmptyCmdStkErr cmd
 352   = hang (ptext SLIT("Non-empty command stack at command:"))
 353          4 (ppr cmd)
 354
 355 kappaUnderflow cmd
 356   = hang (ptext SLIT("Command stack underflow at command:"))
 357          4 (ppr cmd)
 358
 359 badFormFun i tup_ty'
 360  = hang (ptext SLIT("The type of the") <+> speakNth i <+> ptext SLIT("argument of a command form has the wrong shape"))
 361         4 (ptext SLIT("Argument type:") <+> ppr tup_ty')
 362 \end{code}