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