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