summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Gen/Arrow.hs
blob: 65202cdeb23cf9e909db1c49f27e099d5f1f46ea (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
{-# LANGUAGE RankNTypes     #-}
{-# LANGUAGE TypeFamilies   #-}
{-# LANGUAGE BlockArguments #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

-- | Typecheck arrow notation
module GHC.Tc.Gen.Arrow ( tcProc ) where

import GHC.Prelude

import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp
                                       , tcCheckPolyExpr )

import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Gen.Bind
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
import GHC.Core.Multiplicity
import GHC.Core.Coercion
import GHC.Types.Id( mkLocalId )
import GHC.Tc.Utils.Instantiate
import GHC.Builtin.Types
import GHC.Types.Var.Set
import GHC.Builtin.Types.Prim
import GHC.Types.Basic( Arity )
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc

import Control.Monad

{-
Note [Arrow overview]
~~~~~~~~~~~~~~~~~~~~~
Here's a summary of arrows and how they typecheck.  First, here's
a cut-down syntax:

  expr ::= ....
        |  proc pat cmd

  cmd ::= cmd exp                    -- Arrow application
       |  \pat -> cmd                -- Arrow abstraction
       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
       |  ... -- If, case in the usual way

  cmd_type ::= carg_type --> type

  carg_type ::= ()
             |  (type, carg_type)

Note that
 * The 'exp' in an arrow form can mention only
   "arrow-local" variables

 * An "arrow-local" variable is bound by an enclosing
   cmd binding form (eg arrow abstraction)

 * A cmd_type is here written with a funny arrow "-->",
   The bit on the left is a carg_type (command argument type)
   which itself is a nested tuple, finishing with ()

 * The arrow-tail operator (e1 -< e2) means
       (| e1 <<< arr snd |) e2


************************************************************************
*                                                                      *
                Proc
*                                                                      *
************************************************************************
-}

tcProc :: LPat GhcRn -> LHsCmdTop GhcRn         -- proc pat -> expr
       -> ExpRhoType                            -- Expected type of whole proc expression
       -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)

tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty
  = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
        -- start with the names as they are used to desugar the proc itself
        -- See #17423
        ; names' <- setSrcSpanA loc $
            mapM (tcSyntaxName ProcOrigin arr_ty) names
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
        ; (pat', cmd') <- newArrowScope
                          $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)
                          $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)
        ; let res_co = co `mkTransCo` mkAppCo co1 (mkNomReflCo res_ty)
        ; return (pat', cmd', res_co) }

{-
************************************************************************
*                                                                      *
                Commands
*                                                                      *
************************************************************************
-}

-- See Note [Arrow overview]
type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
type CmdArgType = TcTauType                  -- carg_type, a nested tuple

data CmdEnv
  = CmdEnv {
        cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*
    }

mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]

---------------------------------------
tcCmdTop :: CmdEnv
         -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)
         -> LHsCmdTop GhcRn
         -> CmdType
         -> TcM (LHsCmdTop GhcTc)

tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
  = setSrcSpanA loc $
    do  { cmd' <- tcCmd env cmd cmd_ty
        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }

----------------------------------------
tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
        -- The main recursive function
tcCmd env (L loc cmd) cmd_ty@(_, res_ty)
  = setSrcSpan (locA loc) $ do
        { cmd' <- tc_cmd env cmd cmd_ty
        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty
        ; return (L loc cmd') }

tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)
tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty
  = do  { cmd' <- tcCmd env cmd res_ty
        ; return (HsCmdPar x lpar cmd' rpar) }

tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty
  = do  { (binds', body') <- tcLocalBinds binds         $
                             setSrcSpan (locA body_loc) $
                             tc_cmd env body res_ty
        ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) }

tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
  = addErrCtxt (cmdCtxt in_cmd) $ do
      (scrut', scrut_ty) <- tcInferRho scrut
      hasFixedRuntimeRep_syntactic
        (FRRArrow $ ArrowCmdCase)
        scrut_ty
      matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
      return (HsCmdCase x scrut' matches')

tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty
  = addErrCtxt (cmdCtxt cmd)
      do { let match_ctxt = ArrowLamCaseAlt lc_variant
         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match
         ; (wrap, match') <-
             tcCmdMatchLambda env match_ctxt match cmd_ty
         ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }

tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'
  = do  { pred' <- tcCheckMonoExpr pred boolTy
        ; b1'   <- tcCmd env b1 res_ty
        ; b2'   <- tcCmd env b2 res_ty
        ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')
    }

tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if
  = do  { pred_ty <- newOpenFlexiTyVarTy
        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
        -- because we're going to apply it to the environment, not
        -- the return value.
        ; skol_info <- mkSkolemInfo ArrowReboundIfSkol
        ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar]
        ; let r_ty = mkTyVarTy r_tv
        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
                  TcRnArrowIfThenElsePredDependsOnResultTy
        ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun
                              (map synKnownType [pred_ty, r_ty, r_ty])
                              (mkCheckExpType r_ty) $ \ _ _ ->
                           tcCheckMonoExpr pred pred_ty

        ; b1'   <- tcCmd env b1 res_ty
        ; b2'   <- tcCmd env b2 res_ty
        ; return (HsCmdIf x fun' pred' b1' b2')
    }

-------------------------------------------
--              Arrow application
--          (f -< a)   or   (f -<< a)
--
--   D   |- fun :: a t1 t2
--   D,G |- arg :: t1
--  ------------------------
--   D;G |-a  fun -< arg :: stk --> t2
--
--   D,G |- fun :: a t1 t2
--   D,G |- arg :: t1
--  ------------------------
--   D;G |-a  fun -<< arg :: stk --> t2
--
-- (plus -<< requires ArrowApply)

tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
  = addErrCtxt (cmdCtxt cmd)    $
    do  { arg_ty <- newOpenFlexiTyVarTy
        ; let fun_ty = mkCmdArrTy env arg_ty res_ty
        ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty)

        ; arg' <- tcCheckMonoExpr arg arg_ty

        ; hasFixedRuntimeRep_syntactic
            (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)
            fun_ty

        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
  where
       -- Before type-checking f, use the environment of the enclosing
       -- proc for the (-<) case.
       -- Local bindings, inside the enclosing proc, are not in scope
       -- inside f.  In the higher-order case (-<<), they are.
       -- See Note [Escaping the arrow scope] in GHC.Tc.Types
    select_arrow_scope tc = case ho_app of
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> escapeArrowScope tc

-------------------------------------------
--              Command application
--
-- D,G |-  exp : t
-- D;G |-a cmd : (t,stk) --> res
-- -----------------------------
-- D;G |-a cmd exp : stk --> res

tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
  = addErrCtxt (cmdCtxt cmd)    $
    do  { arg_ty <- newOpenFlexiTyVarTy
        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
        ; arg'   <- tcCheckMonoExpr arg arg_ty
        ; hasFixedRuntimeRep_syntactic
            (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))
            arg_ty
        ; return (HsCmdApp x fun' arg') }

-------------------------------------------
--              Lambda
--
-- D;G,x:t |-a cmd : stk --> res
-- ------------------------------
-- D;G |-a (\x.cmd) : (t,stk) --> res

tc_cmd env (HsCmdLam x match) cmd_ty
  = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty
       ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }

-------------------------------------------
--              Do notation

tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }


-----------------------------------------------------------------
--      Arrow ``forms''       (| e c1 .. cn |)
--
--      D; G |-a1 c1 : stk1 --> r1
--      ...
--      D; G |-an cn : stkn --> rn
--      D |-  e :: forall e. a1 (e, stk1) t1
--                                ...
--                        -> an (e, stkn) tn
--                        -> a  (e, stk) t
--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
--      ----------------------------------------------
--      D; G |-a  (| e c1 ... cn |)  :  stk --> t

tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
  = addErrCtxt (cmdCtxt cmd)
    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
                              -- We use alphaTyVar for 'w'
        ; let e_ty = mkInfForAllTy alphaTyVar $
                     mkVisFunTysMany cmd_tys $
                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
        ; expr' <- tcCheckPolyExpr expr e_ty
        ; return (HsCmdArrForm x expr' f fixity cmd_args') }

  where
    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
    tc_cmd_arg cmd@(L loc (HsCmdTop names _))
       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
            ; stk_ty <- newFlexiTyVarTy liftedTypeKind
            ; res_ty <- newFlexiTyVarTy liftedTypeKind
            ; names' <- setSrcSpanA loc $
                mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names
            ; let env' = env { cmd_arr = arr_ty }
            ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }

-- | Typechecking for case command alternatives. Used for 'HsCmdCase'.
tcCmdMatches :: CmdEnv
             -> TcTypeFRR -- ^ Type of the scrutinee.
             -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives
             -> CmdType
             -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatches env scrut_ty matches (stk, res_ty)
  = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
  where
    match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt,
                      mc_body = mc_body }
    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
                              ; tcCmd env body (stk, res_ty') }

-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
tcCmdMatchLambda :: CmdEnv
                 -> HsArrowMatchContext
                 -> MatchGroup GhcRn (LHsCmd GhcRn)
                 -> CmdType
                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatchLambda env
                 ctxt
                 mg@MG { mg_alts = L l matches, mg_ext = origin }
                 (cmd_stk, res_ty)
  = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk

       ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys
       ; matches' <- forM matches $
           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'

       ; let arg_tys' = map unrestricted arg_tys
             mg' = mg { mg_alts = L l matches'
                      , mg_ext = MatchGroupTc arg_tys' res_ty origin }

       ; return (mkWpCastN co, mg') }
  where
    n_pats | isEmptyMatchGroup mg = 1   -- must be lambda-case
           | otherwise            = matchGroupArity mg

    -- Check the patterns, and the GRHSs inside
    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))
      = do { (pats', grhss') <- setSrcSpanA mtch_loc           $
                                tcPats match_ctxt pats arg_tys $
                                tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)

           ; return $ L mtch_loc (Match { m_ext = noAnn
                                        , m_ctxt = match_ctxt
                                        , m_pats = pats'
                                        , m_grhss = grhss' }) }

    match_ctxt = ArrowMatchCtxt ctxt
    pg_ctxt    = PatGuard match_ctxt

    tc_grhss (GRHSs x grhss binds) stk_ty res_ty
        = do { (binds', grhss') <- tcLocalBinds binds $
                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss
             ; return (GRHSs x grhss' binds') }

    tc_grhs stk_ty res_ty (GRHS x guards body)
        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
                                  \ res_ty -> tcCmd env body
                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
             ; return (GRHS x guards' rhs') }

matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType)
matchExpectedCmdArgs 0 ty
  = return (mkNomReflCo ty, [], ty)
matchExpectedCmdArgs n ty
  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
       ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }

{-
************************************************************************
*                                                                      *
                Stmts
*                                                                      *
************************************************************************
-}

--------------------------------
--      Mdo-notation
-- The distinctive features here are
--      (a) RecStmts, and
--      (b) no rebindable syntax

tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
        ; thing <- thing_inside (panic "tcArrDoStmt")
        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }

tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
        ; thing          <- thing_inside res_ty
        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }

tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside
  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
        ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
                            thing_inside res_ty
        ; return (mkTcBindStmt pat' rhs', thing) }

tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
                            , recS_rec_ids = rec_names }) res_ty thing_inside
  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
        ; let tup_ids = zipWith (\n p -> mkLocalId n ManyTy p) tup_names tup_elt_tys
                        -- Many because it's a recursive definition
        ; tcExtendIdEnv tup_ids $ do
        { (stmts', tup_rets)
                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
                        -- ToDo: res_ty not really right
                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)

        ; thing <- thing_inside res_ty
                -- NB:  The rec_ids for the recursive things
                --      already scope over this part. This binding may shadow
                --      some of them with polymorphic things with the same Name
                --      (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr)

        ; let rec_ids = takeList rec_names tup_ids
        ; later_ids <- tcLookupLocalIds later_names

        ; let rec_rets = takeList rec_names tup_rets
        ; let ret_table = zip tup_ids tup_rets
        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]

        ; let
            stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
            stmt = emptyRecStmtId
                                 { recS_stmts = L l stmts'
                                 -- { recS_stmts = _ stmts'
                                 , recS_later_ids = later_ids
                                 , recS_rec_ids = rec_ids
                                 , recS_ext = unitRecStmtTc
                                     { recS_later_rets = later_rets
                                     , recS_rec_rets = rec_rets
                                     , recS_ret_ty = res_ty} }
        ; return (stmt, thing)
        }}

tcArrDoStmt _ _ stmt _ _
  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)

tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
                        ; rhs' <- tcCmd env rhs (unitTy, ty)
                        ; return (rhs', ty) }

{-
************************************************************************
*                                                                      *
                Helpers
*                                                                      *
************************************************************************
-}

mkPairTy :: Type -> Type -> Type
mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]

arrowTyConKind :: Kind          --  *->*->*
arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind

{-
************************************************************************
*                                                                      *
                Errors
*                                                                      *
************************************************************************
-}

cmdCtxt :: HsCmd GhcRn -> SDoc
cmdCtxt cmd = text "In the command:" <+> ppr cmd