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/Commentary/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 TcPat
  31 import TcUnify
  32 import TcRnMonad
  33 import Coercion
  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
  45 import Control.Monad
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50                 Proc
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
  56        -> BoxyRhoType                           -- Expected type of whole proc expression
  57        -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI)
  58
  59 tcProc pat cmd exp_ty
  60   = newArrowScope $
  61     do  { ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty
  62         ; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1
  63         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
  64         ; (pat', cmd') <- tcProcPat pat arg_ty res_ty $
  65                           tcCmdTop cmd_env cmd []
  66         ; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo)
  67         ; return (pat', cmd', res_coi)
  68         }
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74                 Commands
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 type CmdStack = [TcTauType]
  80 data CmdEnv
  81   = CmdEnv {
  82         cmd_arr         :: TcType -- arrow type constructor, of kind *->*->*
  83     }
  84
  85 mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
  86 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
  87
  88 ---------------------------------------
  89 tcCmdTop :: CmdEnv
  90          -> LHsCmdTop Name
  91          -> CmdStack
  92          -> TcTauType   -- Expected result type; always a monotype
  93                              -- We know exactly how many cmd args are expected,
  94                              -- albeit perhaps not their types; so we can pass
  95                              -- in a CmdStack
  96         -> TcM (LHsCmdTop TcId)
  97
  98 tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
  99   = setSrcSpan loc $
 100     do  { cmd'   <- tcGuardedCmd env cmd cmd_stk res_ty
 101         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
 102         ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
 103
 104
 105 ----------------------------------------
 106 tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
 107              -> TcTauType -> TcM (LHsExpr TcId)
 108 -- A wrapper that deals with the refinement (if any)
 109 tcGuardedCmd env expr stk res_ty
 110   = do  { body <- tcCmd env expr (stk, res_ty)
 111         ; return body
 112         }
 113
 114 tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
 115         -- The main recursive function
 116 tcCmd env (L loc expr) res_ty
 117   = setSrcSpan loc $ do
 118         { expr' <- tc_cmd env expr res_ty
 119         ; return (L loc expr') }
 120
 121 tc_cmd env (HsPar cmd) res_ty
 122   = do  { cmd' <- tcCmd env cmd res_ty
 123         ; return (HsPar cmd') }
 124
 125 tc_cmd env (HsLet binds (L body_loc body)) res_ty
 126   = do  { (binds', body') <- tcLocalBinds binds         $
 127                              setSrcSpan body_loc        $
 128                              tc_cmd env body res_ty
 129         ; return (HsLet binds' (L body_loc body')) }
 130
 131 tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
 132   = addErrCtxt (cmdCtxt in_cmd) $ do
 133       (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) $
 134                               tcInferRho scrut
 135       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
 136       return (HsCase scrut' matches')
 137   where
 138     match_ctxt = MC { mc_what = CaseAlt,
 139                       mc_body = mc_body }
 140     mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
 141
 142 tc_cmd env (HsIf pred b1 b2) res_ty
 143   = do  { pred' <- tcMonoExpr pred boolTy
 144         ; b1'   <- tcCmd env b1 res_ty
 145         ; b2'   <- tcCmd env b2 res_ty
 146         ; return (HsIf pred' b1' b2')
 147     }
 148
 149 -------------------------------------------
 150 --              Arrow application
 151 --          (f -< a)   or   (f -<< a)
 152
 153 tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
 154   = addErrCtxt (cmdCtxt cmd)    $
 155     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 156         ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
 157
 158         ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
 159
 160         ; arg' <- tcMonoExpr arg arg_ty
 161
 162         ; return (HsArrApp fun' arg' fun_ty ho_app lr) }
 163   where
 164         -- Before type-checking f, use the environment of the enclosing
 165         -- proc for the (-<) case.
 166         -- Local bindings, inside the enclosing proc, are not in scope
 167         -- inside f.  In the higher-order case (-<<), they are.
 168     select_arrow_scope tc = case ho_app of
 169         HsHigherOrderApp -> tc
 170         HsFirstOrderApp  -> escapeArrowScope tc
 171
 172 -------------------------------------------
 173 --              Command application
 174
 175 tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
 176   = addErrCtxt (cmdCtxt cmd)    $
 177     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 178
 179         ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
 180
 181         ; arg' <- tcMonoExpr arg arg_ty
 182
 183         ; return (HsApp fun' arg') }
 184
 185 -------------------------------------------
 186 --              Lambda
 187
 188 tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _))
 189        (cmd_stk, res_ty)
 190   = addErrCtxt (matchCtxt match_ctxt match)     $
 191
 192     do  {       -- Check the cmd stack is big enough
 193         ; checkTc (lengthAtLeast cmd_stk n_pats)
 194                   (kappaUnderflow cmd)
 195
 196                 -- Check the patterns, and the GRHSs inside
 197         ; (pats', grhss') <- setSrcSpan mtch_loc                $
 198                              tcLamPats pats cmd_stk res_ty      $
 199                              tc_grhss grhss
 200
 201         ; let match' = L mtch_loc (Match pats' Nothing grhss')
 202         ; return (HsLam (MatchGroup [match'] res_ty))
 203         }
 204
 205   where
 206     n_pats     = length pats
 207     stk'       = drop n_pats cmd_stk
 208     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
 209     pg_ctxt    = PatGuard match_ctxt
 210
 211     tc_grhss (GRHSs grhss binds) res_ty
 212         = do { (binds', grhss') <- tcLocalBinds binds $
 213                                    mapM (wrapLocM (tc_grhs res_ty)) grhss
 214              ; return (GRHSs grhss' binds') }
 215
 216     tc_grhs res_ty (GRHS guards body)
 217         = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
 218                                   tcGuardedCmd env body stk'
 219              ; return (GRHS guards' rhs') }
 220
 221 -------------------------------------------
 222 --              Do notation
 223
 224 tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
 225   = do  { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
 226         ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts res_ty $
 227                              tcGuardedCmd env body []
 228         ; return (HsDo do_or_lc stmts' body' res_ty) }
 229   where
 230     tc_stmt = tcMDoStmt tc_rhs
 231     tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
 232                     ; rhs' <- tcCmd env rhs ([], ty)
 233                     ; return (rhs', ty) }
 234
 235
 236 -----------------------------------------------------------------
 237 --      Arrow ``forms''       (| e c1 .. cn |)
 238 --
 239 --      G      |-b  c : [s1 .. sm] s
 240 --      pop(G) |-   e : forall w. b ((w,s1) .. sm) s
 241 --                              -> a ((w,t1) .. tn) t
 242 --      e \not\in (s, s1..sm, t, t1..tn)
 243 --      ----------------------------------------------
 244 --      G |-a  (| e c |)  :  [t1 .. tn] t
 245
 246 tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 247   = addErrCtxt (cmdCtxt cmd)    $
 248     do  { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
 249         ; span       <- getSrcSpanM
 250         ; [w_tv]     <- tcInstSkolTyVars ArrowSkol [alphaTyVar]
 251         ; let w_ty = mkTyVarTy w_tv     -- Just a convenient starting point
 252
 253                 --  a ((w,t1) .. tn) t
 254         ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
 255
 256                 --   b ((w,s1) .. sm) s
 257                 --   -> a ((w,t1) .. tn) t
 258         ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys]
 259                               e_res_ty
 260
 261                 -- Check expr
 262         ; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty))
 263         ; loc <- getInstLoc (SigOrigin ArrowSkol)
 264         ; inst_binds <- tcSimplifyCheck loc [w_tv] [] lie
 265
 266                 -- Check that the polymorphic variable hasn't been unified with anything
 267                 -- and is not free in res_ty or the cmd_stk  (i.e.  t, t1..tn)
 268         ; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv]
 269
 270                 -- OK, now we are in a position to unscramble
 271                 -- the s1..sm and check each cmd
 272         ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
 273
 274         ; return (HsArrForm (noLoc $ HsWrap (WpTyLam w_tv)
 275                                                (unLoc $ mkHsDictLet inst_binds expr'))
 276                              fixity cmds')
 277         }
 278   where
 279         -- Make the types
 280         --      b, ((e,s1) .. sm), s
 281     new_cmd_ty :: LHsCmdTop Name -> Int
 282                -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
 283     new_cmd_ty cmd i
 284           = do  { b_ty   <- newFlexiTyVarTy arrowTyConKind
 285                 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
 286                         -- We actually make a type variable for the tuple
 287                         -- because we don't know how deeply nested it is yet
 288                 ; s_ty   <- newFlexiTyVarTy liftedTypeKind
 289                 ; return (cmd, i, b_ty, tup_ty, s_ty)
 290                 }
 291
 292     tc_cmd w_tv (cmd, i, b, tup_ty, s)
 293       = do { tup_ty' <- zonkTcType tup_ty
 294            ; let (corner_ty, arg_tys) = unscramble tup_ty'
 295
 296                 -- Check that it has the right shape:
 297                 --      ((w,s1) .. sn)
 298                 -- where the si do not mention w
 299            ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv &&
 300                       not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
 301                      (badFormFun i tup_ty')
 302
 303            ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
 304
 305     unscramble :: TcType -> (TcType, [TcType])
 306     -- unscramble ((w,s1) .. sn)        =  (w, [s1..sn])
 307     unscramble ty
 308        = case tcSplitTyConApp_maybe ty of
 309             Just (tc, [t,s]) | tc == pairTyCon
 310                ->  let
 311                       (w,ss) = unscramble t
 312                    in (w, s:ss)
 313
 314             other -> (ty, [])
 315
 316 -----------------------------------------------------------------
 317 --              Base case for illegal commands
 318 -- This is where expressions that aren't commands get rejected
 319
 320 tc_cmd env cmd _
 321   = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd),
 322                       ptext SLIT("was found where an arrow command was expected")])
 323 \end{code}
 324
 325
 326 %************************************************************************
 327 %*                                                                      *
 328                 Helpers
 329 %*                                                                      *
 330 %************************************************************************
 331
 332
 333 \begin{code}
 334 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
 335
 336 arrowTyConKind :: Kind          --  *->*->*
 337 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
 338 \end{code}
 339
 340
 341 %************************************************************************
 342 %*                                                                      *
 343                 Errors
 344 %*                                                                      *
 345 %************************************************************************
 346
 347 \begin{code}
 348 cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd
 349
 350 caseScrutCtxt cmd
 351   = hang (ptext SLIT("In the scrutinee of a case command:")) 4 (ppr cmd)
 352
 353 nonEmptyCmdStkErr cmd
 354   = hang (ptext SLIT("Non-empty command stack at command:"))
 355          4 (ppr cmd)
 356
 357 kappaUnderflow cmd
 358   = hang (ptext SLIT("Command stack underflow at command:"))
 359          4 (ppr cmd)
 360
 361 badFormFun i tup_ty'
 362  = hang (ptext SLIT("The type of the") <+> speakNth i <+> ptext SLIT("argument of a command form has the wrong shape"))
 363         4 (ptext SLIT("Argument type:") <+> ppr tup_ty')
 364 \end{code}