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 TcHsSyn( hsLPatType )
  22 import TcType
  23 import TcMType
  24 import TcBinds
  25 import TcPat
  26 import TcUnify
  27 import TcRnMonad
  28 import TcEnv
  29 import TcEvidence
  30 import Id( mkLocalId )
  31 import Inst
  32 import Name
  33 import TysWiredIn
  34 import VarSet
  35 import TysPrim
  36
  37 import SrcLoc
  38 import Outputable
  39 import FastString
  40 import Util
  41
  42 import Control.Monad
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47                 Proc
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
  53        -> TcRhoType                             -- Expected type of whole proc expression
  54        -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)
  55
  56 tcProc pat cmd exp_ty
  57   = newArrowScope $
  58     do  { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
  59         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
  60         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
  61         ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
  62                           tcCmdTop cmd_env cmd [] res_ty
  63         ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcReflCo res_ty))
  64         ; return (pat', cmd', res_co) }
  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          -> 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 res_ty
  95   = setSrcSpan loc $
  96     do  { cmd'   <- tcCmd env cmd (cmd_stk, 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 tcCmd  :: CmdEnv -> LHsCmd Name -> (CmdStack, TcTauType) -> TcM (LHsCmd TcId)
 103         -- The main recursive function
 104 tcCmd env (L loc cmd) res_ty
 105   = setSrcSpan loc $ do
 106         { cmd' <- tc_cmd env cmd res_ty
 107         ; return (L loc cmd') }
 108
 109 tc_cmd :: CmdEnv -> HsCmd Name  -> (CmdStack, TcTauType) -> TcM (HsCmd TcId)
 110 tc_cmd env (HsCmdPar cmd) res_ty
 111   = do  { cmd' <- tcCmd env cmd res_ty
 112         ; return (HsCmdPar cmd') }
 113
 114 tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty
 115   = do  { (binds', body') <- tcLocalBinds binds         $
 116                              setSrcSpan body_loc        $
 117                              tc_cmd env body res_ty
 118         ; return (HsCmdLet binds' (L body_loc body')) }
 119
 120 tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
 121   = addErrCtxt (cmdCtxt in_cmd) $ do
 122       (scrut', scrut_ty) <- tcInferRho scrut
 123       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
 124       return (HsCmdCase scrut' matches')
 125   where
 126     match_ctxt = MC { mc_what = CaseAlt,
 127                       mc_body = mc_body }
 128     mc_body body res_ty' = tcCmd env body (stk, res_ty')
 129
 130 tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
 131   = do  { pred' <- tcMonoExpr pred boolTy
 132         ; b1'   <- tcCmd env b1 res_ty
 133         ; b2'   <- tcCmd env b2 res_ty
 134         ; return (HsCmdIf Nothing pred' b1' b2')
 135     }
 136
 137 tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
 138   = do  { pred_ty <- newFlexiTyVarTy openTypeKind
 139         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
 140         -- because we're going to apply it to the environment, not
 141         -- the return value.
 142         ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
 143         ; let r_ty = mkTyVarTy r_tv
 144         ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty
 145         ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty))
 146                   (ptext (sLit "Predicate type of `ifThenElse' depends on result type"))
 147         ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
 148         ; pred' <- tcMonoExpr pred pred_ty
 149         ; b1'   <- tcCmd env b1 res_ty
 150         ; b2'   <- tcCmd env b2 res_ty
 151         ; return (HsCmdIf (Just fun') pred' b1' b2')
 152     }
 153
 154 -------------------------------------------
 155 --              Arrow application
 156 --          (f -< a)   or   (f -<< a)
 157
 158 tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
 159   = addErrCtxt (cmdCtxt cmd)    $
 160     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 161         ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
 162
 163         ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
 164              -- ToDo: There should be no need for the escapeArrowScope stuff
 165              -- See Note [Escaping the arrow scope] in TcRnTypes
 166
 167         ; arg' <- tcMonoExpr arg arg_ty
 168
 169         ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
 170   where
 171        -- Before type-checking f, use the environment of the enclosing
 172        -- proc for the (-<) case.
 173        -- Local bindings, inside the enclosing proc, are not in scope
 174        -- inside f.  In the higher-order case (-<<), they are.
 175     select_arrow_scope tc = case ho_app of
 176         HsHigherOrderApp -> tc
 177         HsFirstOrderApp  -> escapeArrowScope tc
 178
 179 -------------------------------------------
 180 --              Command application
 181
 182 tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
 183   = addErrCtxt (cmdCtxt cmd)    $
 184     do  { arg_ty <- newFlexiTyVarTy openTypeKind
 185
 186         ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
 187
 188         ; arg' <- tcMonoExpr arg arg_ty
 189
 190         ; return (HsCmdApp fun' arg') }
 191
 192 -------------------------------------------
 193 --              Lambda
 194
 195 tc_cmd env cmd@(HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] }))
 196        (cmd_stk, res_ty)
 197   = addErrCtxt (pprMatchInCtxt match_ctxt match)        $
 198
 199     do  {       -- Check the cmd stack is big enough
 200         ; checkTc (lengthAtLeast cmd_stk n_pats)
 201                   (kappaUnderflow cmd)
 202
 203                 -- Check the patterns, and the GRHSs inside
 204         ; (pats', grhss') <- setSrcSpan mtch_loc                $
 205                              tcPats LambdaExpr pats cmd_stk     $
 206                              tc_grhss grhss res_ty
 207
 208         ; let match' = L mtch_loc (Match pats' Nothing grhss')
 209               arg_tys = map hsLPatType pats'
 210         ; return (HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
 211                                , mg_res_ty = res_ty }))
 212               -- Or should we decompose res_ty?
 213         }
 214
 215   where
 216     n_pats     = length pats
 217     stk'       = drop n_pats cmd_stk
 218     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
 219     pg_ctxt    = PatGuard match_ctxt
 220
 221     tc_grhss (GRHSs grhss binds) res_ty
 222         = do { (binds', grhss') <- tcLocalBinds binds $
 223                                    mapM (wrapLocM (tc_grhs res_ty)) grhss
 224              ; return (GRHSs grhss' binds') }
 225
 226     tc_grhs res_ty (GRHS guards body)
 227         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
 228                                   \ res_ty -> tcCmd env body (stk', res_ty)
 229              ; return (GRHS guards' rhs') }
 230
 231 -------------------------------------------
 232 --              Do notation
 233
 234 tc_cmd env cmd@(HsCmdDo stmts _) (cmd_stk, res_ty)
 235   = do  { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
 236         ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
 237         ; return (HsCmdDo stmts' res_ty) }
 238   where
 239
 240
 241 -----------------------------------------------------------------
 242 --      Arrow ``forms''       (| e c1 .. cn |)
 243 --
 244 --      G      |-b  c : [s1 .. sm] s
 245 --      pop(G) |-   e : forall w. b ((w,s1) .. sm) s
 246 --                              -> a ((w,t1) .. tn) t
 247 --      e \not\in (s, s1..sm, t, t1..tn)
 248 --      ----------------------------------------------
 249 --      G |-a  (| e c |)  :  [t1 .. tn] t
 250
 251 tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 252   = addErrCtxt (cmdCtxt cmd)    $
 253     do  { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
 254         ; (_, [w_tv])     <- tcInstSkolTyVars [alphaTyVar]
 255         ; let w_ty = mkTyVarTy w_tv     -- Just a convenient starting point
 256
 257                 --  a ((w,t1) .. tn) t
 258         ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
 259
 260                 --   b ((w,s1) .. sm) s
 261                 --   -> a ((w,t1) .. tn) t
 262         ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys]
 263                               e_res_ty
 264
 265   -- ToDo: SLPJ: something is badly wrong here.
 266   -- The escapeArrowScope pops the Untouchables.. but that
 267   -- risks screwing up the skolem-escape check
 268   -- Moreover, arrowfail001 fails with an ASSERT failure
 269   -- because a variable gets the wrong level
 270                 -- Check expr
 271         ; (inner_binds, expr')
 272                <- checkConstraints ArrowSkol [w_tv] [] $
 273                   escapeArrowScope (tcMonoExpr expr e_ty)
 274
 275 {-
 276         ; ((inner_binds, expr'), lie)
 277                <- captureConstraints $
 278                   checkConstraints ArrowSkol [w_tv] [] $
 279                   tcMonoExpr expr e_ty
 280                                  -- No need for escapeArrowScope in the
 281                                  -- type checker.
 282                                  -- Note [Escaping the arrow scope] in TcRnTypes
 283         ; (lie, outer_binds) <- solveWantedsTcM lie
 284         ; emitConstraints lie
 285 -}
 286
 287                 -- OK, now we are in a position to unscramble
 288                 -- the s1..sm and check each cmd
 289         ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
 290
 291         ; let wrap = WpTyLam w_tv <.> mkWpLet inner_binds
 292         ; return (HsCmdArrForm (mkLHsWrap wrap expr') fixity cmds') }
 293   where
 294         -- Make the types
 295         --      b, ((e,s1) .. sm), s
 296     new_cmd_ty :: LHsCmdTop Name -> Int
 297                -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
 298     new_cmd_ty cmd i
 299           = do  { b_ty   <- newFlexiTyVarTy arrowTyConKind
 300                 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
 301                         -- We actually make a type variable for the tuple
 302                         -- because we don't know how deeply nested it is yet
 303                 ; s_ty   <- newFlexiTyVarTy liftedTypeKind
 304                 ; return (cmd, i, b_ty, tup_ty, s_ty)
 305                 }
 306
 307     tc_cmd w_tv (cmd, i, b, tup_ty, s)
 308       = do { tup_ty' <- zonkTcType tup_ty
 309            ; let (corner_ty, arg_tys) = unscramble tup_ty'
 310
 311                 -- Check that it has the right shape:
 312                 --      ((w,s1) .. sn)
 313                 -- where the si do not mention w
 314            ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv)
 315            ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
 316                      (badFormFun i tup_ty')
 317      -- JPM: WARNING: this test is utterly bogus; see #5609
 318      -- We are not using the coercion returned by the unify;
 319      -- and (even more seriously) the w not in arg_tys test is totally
 320      -- bogus if there are suspended equality constraints. This code
 321      -- needs to be re-architected.
 322
 323            ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s }
 324
 325     unscramble :: TcType -> (TcType, [TcType])
 326     -- unscramble ((w,s1) .. sn)        =  (w, [s1..sn])
 327     unscramble ty = unscramble' ty []
 328
 329     unscramble' ty ss
 330        = case tcSplitTyConApp_maybe ty of
 331             Just (tc, [t,s]) | tc == pairTyCon
 332                ->  unscramble' t (s:ss)
 333             _ -> (ty, ss)
 334
 335 -----------------------------------------------------------------
 336 --              Base case for illegal commands
 337 -- This is where expressions that aren't commands get rejected
 338
 339 tc_cmd _ cmd _
 340   = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd),
 341                       ptext (sLit "was found where an arrow command was expected")])
 342 \end{code}
 343
 344
 345 %************************************************************************
 346 %*                                                                      *
 347                 Stmts
 348 %*                                                                      *
 349 %************************************************************************
 350
 351 \begin{code}
 352 --------------------------------
 353 --      Mdo-notation
 354 -- The distinctive features here are
 355 --      (a) RecStmts, and
 356 --      (b) no rebindable syntax
 357
 358 tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
 359 tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
 360   = do  { rhs' <- tcCmd env rhs ([], res_ty)
 361         ; thing <- thing_inside (panic "tcArrDoStmt")
 362         ; return (LastStmt rhs' noSyntaxExpr, thing) }
 363
 364 tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside
 365   = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
 366         ; thing          <- thing_inside res_ty
 367         ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
 368
 369 tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 370   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
 371         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 372                             thing_inside res_ty
 373         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 374
 375 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 376                             , recS_rec_ids = rec_names }) res_ty thing_inside
 377   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
 378         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
 379         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
 380         ; tcExtendIdEnv tup_ids $ do
 381         { (stmts', tup_rets)
 382                 <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
 383                         -- ToDo: res_ty not really right
 384                    zipWithM tcCheckId tup_names tup_elt_tys
 385
 386         ; thing <- thing_inside res_ty
 387                 -- NB:  The rec_ids for the recursive things
 388                 --      already scope over this part. This binding may shadow
 389                 --      some of them with polymorphic things with the same Name
 390                 --      (see note [RecStmt] in HsExpr)
 391
 392         ; let rec_ids = takeList rec_names tup_ids
 393         ; later_ids <- tcLookupLocalIds later_names
 394
 395         ; let rec_rets = takeList rec_names tup_rets
 396         ; let ret_table = zip tup_ids tup_rets
 397         ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
 398
 399         ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 400                                , recS_later_rets = later_rets
 401                                , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
 402                                , recS_ret_ty = res_ty }, thing)
 403         }}
 404
 405 tcArrDoStmt _ _ stmt _ _
 406   = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
 407
 408 tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType)
 409 tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
 410                         ; rhs' <- tcCmd env rhs ([], ty)
 411                         ; return (rhs', ty) }
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417                 Helpers
 418 %*                                                                      *
 419 %************************************************************************
 420
 421
 422 \begin{code}
 423 mkPairTy :: Type -> Type -> Type
 424 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
 425
 426 arrowTyConKind :: Kind          --  *->*->*
 427 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
 428 \end{code}
 429
 430
 431 %************************************************************************
 432 %*                                                                      *
 433                 Errors
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 \begin{code}
 438 cmdCtxt :: HsCmd Name -> SDoc
 439 cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
 440
 441 nonEmptyCmdStkErr :: HsCmd Name -> SDoc
 442 nonEmptyCmdStkErr cmd
 443   = hang (ptext (sLit "Non-empty command stack at command:"))
 444        2 (ppr cmd)
 445
 446 kappaUnderflow :: HsCmd Name -> SDoc
 447 kappaUnderflow cmd
 448   = hang (ptext (sLit "Command stack underflow at command:"))
 449        2 (ppr cmd)
 450
 451 badFormFun :: Int -> TcType -> SDoc
 452 badFormFun i tup_ty'
 453  = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape"))
 454       2 (ptext (sLit "Argument type:") <+> ppr tup_ty')
 455 \end{code}