ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 #ifdef GHCI     /* Only if bootstrapped */
  12 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  13 import Id               ( Id )
  14 import TcType           ( isTauTy )
  15 import TcEnv            ( checkWellStaged )
  16 import qualified DsMeta
  17 #endif
  18
  19 import HsSyn            ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
  20                           HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar,
  21                           nlHsApp )
  22 import TcHsSyn          ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) )
  23 import TcRnMonad
  24 import TcUnify          ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
  25                           unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy )
  26 import BasicTypes       ( isMarkedStrict )
  27 import Inst             ( InstOrigin(..),
  28                           newOverloadedLit, newMethodFromName, newIPDict,
  29                           newDicts, newMethodWithGivenTy,
  30                           instToId, tcInstCall, tcInstDataCon
  31                         )
  32 import TcBinds          ( tcBindsAndThen )
  33 import TcEnv            ( tcLookup, tcLookupId, checkProcLevel,
  34                           tcLookupDataCon, tcLookupGlobalId
  35                         )
  36 import TcArrows         ( tcProc )
  37 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
  38 import TcHsType         ( tcHsSigType, UserTypeCtxt(..) )
  39 import TcPat            ( badFieldCon )
  40 import TcMType          ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType )
  41 import TcType           ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
  42                           tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
  43                           isSigmaTy, mkFunTy, mkFunTys,
  44                           mkTyConApp, tyVarsOfTypes, isLinearPred,
  45                           liftedTypeKind, openTypeKind,
  46                           tcSplitSigmaTy, tidyOpenType
  47                         )
  48 import FieldLabel       ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
  49 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  50 import DataCon          ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
  51 import Name             ( Name )
  52 import TyCon            ( TyCon, tyConTyVars, tyConTheta, tyConDataCons )
  53 import Subst            ( mkTopTyVarSubst, substTheta, substTy )
  54 import VarSet           ( emptyVarSet, elemVarSet )
  55 import TysWiredIn       ( boolTy )
  56 import PrelNames        ( enumFromName, enumFromThenName,
  57                           enumFromToName, enumFromThenToName,
  58                           enumFromToPName, enumFromThenToPName
  59                         )
  60 import ListSetOps       ( minusList )
  61 import CmdLineOpts
  62 import HscTypes         ( TyThing(..) )
  63 import SrcLoc           ( Located(..), unLoc, getLoc )
  64 import Util
  65 import Outputable
  66 import FastString
  67
  68 #ifdef DEBUG
  69 import TyCon            ( isAlgTyCon )
  70 #endif
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{Main wrappers}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 -- tcCheckSigma does type *checking*; it's passed the expected type of the result
  81 tcCheckSigma :: LHsExpr Name            -- Expession to type check
  82              -> TcSigmaType             -- Expected type (could be a polytpye)
  83              -> TcM (LHsExpr TcId)      -- Generalised expr with expected type
  84
  85 tcCheckSigma expr expected_ty
  86   = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
  87     tc_expr' expr expected_ty
  88
  89 tc_expr' expr sigma_ty
  90   | isSigmaTy sigma_ty
  91   = tcGen sigma_ty emptyVarSet (
  92         \ rho_ty -> tcCheckRho expr rho_ty
  93     )                           `thenM` \ (gen_fn, expr') ->
  94     returnM (L (getLoc expr') (gen_fn <$> unLoc expr'))
  95
  96 tc_expr' expr rho_ty    -- Monomorphic case
  97   = tcCheckRho expr rho_ty
  98 \end{code}
  99
 100 Typecheck expression which in most cases will be an Id.
 101 The expression can return a higher-ranked type, such as
 102         (forall a. a->a) -> Int
 103 so we must create a hole to pass in as the expected tyvar.
 104
 105 \begin{code}
 106 tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 107 tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty)
 108
 109 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 110 tcInferRho (L loc (HsVar name)) = addSrcSpan loc $
 111                                   do { (e,ty) <- tcId name; return (L loc e, ty)}
 112 tcInferRho expr                 = newHole                       `thenM` \ hole ->
 113                                   tcMonoExpr expr (Infer hole)  `thenM` \ expr' ->
 114                                   readMutVar hole               `thenM` \ rho_ty ->
 115                                   returnM (expr', rho_ty)
 116 \end{code}
 117
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection{The TAUT rules for variables}TcExpr
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 \begin{code}
 127 tcMonoExpr :: LHsExpr Name              -- Expession to type check
 128            -> Expected TcRhoType        -- Expected type (could be a type variable)
 129                                         -- Definitely no foralls at the top
 130                                         -- Can be a 'hole'.
 131            -> TcM (LHsExpr TcId)
 132
 133 tcMonoExpr (L loc expr) res_ty
 134   = addSrcSpan loc (do { expr' <- tc_expr expr res_ty
 135                        ; return (L loc expr') })
 136
 137 tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
 138 tc_expr (HsVar name) res_ty
 139   = tcId name                   `thenM` \ (expr', id_ty) ->
 140     tcSubExp res_ty id_ty       `thenM` \ co_fn ->
 141     returnM (co_fn <$> expr')
 142
 143 tc_expr (HsIPVar ip) res_ty
 144   =     -- Implicit parameters must have a *tau-type* not a
 145         -- type scheme.  We enforce this by creating a fresh
 146         -- type variable as its type.  (Because res_ty may not
 147         -- be a tau-type.)
 148     newTyVarTy openTypeKind             `thenM` \ ip_ty ->
 149     newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) ->
 150     extendLIE inst                      `thenM_`
 151     tcSubExp res_ty ip_ty               `thenM` \ co_fn ->
 152     returnM (co_fn <$> HsIPVar ip')
 153 \end{code}
 154
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsection{Expressions type signatures}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162 \begin{code}
 163 tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
 164  = addErrCtxt (exprSigCtxt in_expr)                     $
 165    tcHsSigType ExprSigCtxt poly_ty                      `thenM` \ sig_tc_ty ->
 166    tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty    `thenM` \ (co_fn, expr') ->
 167    returnM (co_fn <$> unLoc expr')
 168         -- ToDo: nasty unLoc
 169
 170 tc_expr (HsType ty) res_ty
 171   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 172         -- This is the syntax for type applications that I was planning
 173         -- but there are difficulties (e.g. what order for type args)
 174         -- so it's not enabled yet.
 175         -- Can't eliminate it altogether from the parser, because the
 176         -- same parser parses *patterns*.
 177 \end{code}
 178
 179
 180 %************************************************************************
 181 %*                                                                      *
 182 \subsection{Other expression forms}
 183 %*                                                                      *
 184 %************************************************************************
 185
 186 \begin{code}
 187 tc_expr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 188                                   returnM (HsPar expr')
 189 tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 190                                   returnM (HsSCC lbl expr')
 191 tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->  -- hdaume: core annotation
 192                                          returnM (HsCoreAnn lbl expr')
 193
 194 tc_expr (HsLit lit) res_ty  = tcLit lit res_ty
 195
 196 tc_expr (HsOverLit lit) res_ty
 197   = zapExpectedType res_ty      `thenM` \ res_ty' ->
 198     newOverloadedLit (LiteralOrigin lit) lit res_ty'    `thenM` \ lit_expr ->
 199     returnM (unLoc lit_expr)    -- ToDo: nasty unLoc
 200
 201 tc_expr (NegApp expr neg_name) res_ty
 202   = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty
 203         -- ToDo: use tcSyntaxName
 204
 205 tc_expr (HsLam match) res_ty
 206   = tcMatchLambda match res_ty          `thenM` \ match' ->
 207     returnM (HsLam match')
 208
 209 tc_expr (HsApp e1 e2) res_ty
 210   = tcApp e1 [e2] res_ty
 211 \end{code}
 212
 213 Note that the operators in sections are expected to be binary, and
 214 a type error will occur if they aren't.
 215
 216 \begin{code}
 217 -- Left sections, equivalent to
 218 --      \ x -> e op x,
 219 -- or
 220 --      \ x -> op e x,
 221 -- or just
 222 --      op e
 223
 224 tc_expr in_expr@(SectionL arg1 op) res_ty
 225   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 226     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 227     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 228     addErrCtxt (exprCtxt in_expr)               $
 229     tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
 230     returnM (co_fn <$> SectionL arg1' op')
 231
 232 -- Right sections, equivalent to \ x -> x op expr, or
 233 --      \ x -> op x expr
 234
 235 tc_expr in_expr@(SectionR op arg2) res_ty
 236   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 237     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 238     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 239     addErrCtxt (exprCtxt in_expr)               $
 240     tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
 241     returnM (co_fn <$> SectionR op' arg2')
 242
 243 -- equivalent to (op e1) e2:
 244
 245 tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty
 246   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 247     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 248     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 249     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 250     addErrCtxt (exprCtxt in_expr)               $
 251     tcSubExp res_ty op_res_ty                   `thenM` \ co_fn ->
 252     returnM (OpApp arg1' op' fix arg2')
 253 \end{code}
 254
 255 \begin{code}
 256 tc_expr (HsLet binds (L loc expr)) res_ty
 257   = tcBindsAndThen
 258         glue
 259         binds                   -- Bindings to check
 260         (tc_expr expr res_ty)
 261   where
 262     glue bind expr = HsLet [bind] (L loc expr)
 263
 264 tc_expr in_expr@(HsCase scrut matches) res_ty
 265   = addErrCtxt (caseCtxt in_expr)       $
 266
 267         -- Typecheck the case alternatives first.
 268         -- The case patterns tend to give good type info to use
 269         -- when typechecking the scrutinee.  For example
 270         --      case (map f) of
 271         --        (x:xs) -> ...
 272         -- will report that map is applied to too few arguments
 273
 274     tcMatchesCase match_ctxt matches res_ty     `thenM`    \ (scrut_ty, matches') ->
 275
 276     addErrCtxt (caseScrutCtxt scrut)    (
 277       tcCheckRho scrut scrut_ty
 278     )                                   `thenM`    \ scrut' ->
 279
 280     returnM (HsCase scrut' matches')
 281   where
 282     match_ctxt = MC { mc_what = CaseAlt,
 283                       mc_body = tcMonoExpr }
 284
 285 tc_expr (HsIf pred b1 b2) res_ty
 286   = addErrCtxt (predCtxt pred) (
 287     tcCheckRho pred boolTy      )       `thenM`    \ pred' ->
 288
 289     zapExpectedType res_ty              `thenM`    \ res_ty' ->
 290         -- C.f. the call to zapToType in TcMatches.tcMatches
 291
 292     tcCheckRho b1 res_ty'               `thenM`    \ b1' ->
 293     tcCheckRho b2 res_ty'               `thenM`    \ b2' ->
 294     returnM (HsIf pred' b1' b2')
 295
 296 tc_expr (HsDo do_or_lc stmts method_names _) res_ty
 297   = zapExpectedType res_ty                              `thenM` \ res_ty' ->
 298         -- All comprehensions yield a monotype
 299     tcDoStmts do_or_lc stmts method_names res_ty'       `thenM` \ (stmts', methods') ->
 300     returnM (HsDo do_or_lc stmts' methods' res_ty')
 301
 302 tc_expr in_expr@(ExplicitList _ exprs) res_ty   -- Non-empty list
 303   = zapToListTy res_ty                `thenM` \ elt_ty ->
 304     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 305     returnM (ExplicitList elt_ty exprs')
 306   where
 307     tc_elt elt_ty expr
 308       = addErrCtxt (listCtxt expr) $
 309         tcCheckRho expr elt_ty
 310
 311 tc_expr in_expr@(ExplicitPArr _ exprs) res_ty   -- maybe empty
 312   = zapToPArrTy res_ty                `thenM` \ elt_ty ->
 313     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 314     returnM (ExplicitPArr elt_ty exprs')
 315   where
 316     tc_elt elt_ty expr
 317       = addErrCtxt (parrCtxt expr) $
 318         tcCheckRho expr elt_ty
 319
 320 tc_expr (ExplicitTuple exprs boxity) res_ty
 321   = zapToTupleTy boxity (length exprs) res_ty   `thenM` \ arg_tys ->
 322     tcCheckRhos exprs arg_tys                   `thenM` \ exprs' ->
 323     returnM (ExplicitTuple exprs' boxity)
 324
 325 tc_expr (HsProc pat cmd) res_ty
 326   = tcProc pat cmd res_ty                       `thenM` \ (pat', cmd') ->
 327     returnM (HsProc pat' cmd')
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332                 Record construction and update
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 tc_expr expr@(RecordCon con@(L _ con_name) rbinds) res_ty
 338   = addErrCtxt (recordConCtxt expr)             $
 339     addLocM tcId con                    `thenM` \ (con_expr, con_tau) ->
 340     let
 341         (_, record_ty)   = tcSplitFunTys con_tau
 342         (tycon, ty_args) = tcSplitTyConApp record_ty
 343     in
 344     ASSERT( isAlgTyCon tycon )
 345     zapExpectedTo res_ty record_ty      `thenM_`
 346
 347         -- Check that the record bindings match the constructor
 348         -- con_name is syntactically constrained to be a data constructor
 349     tcLookupDataCon con_name            `thenM` \ data_con ->
 350     let
 351         bad_fields = badFields rbinds data_con
 352     in
 353     if notNull bad_fields then
 354         mappM (addErrTc . badFieldCon data_con) bad_fields      `thenM_`
 355         failM   -- Fail now, because tcRecordBinds will crash on a bad field
 356     else
 357
 358         -- Typecheck the record bindings
 359     tcRecordBinds tycon ty_args rbinds          `thenM` \ rbinds' ->
 360
 361         -- Check for missing fields
 362     checkMissingFields data_con rbinds          `thenM_`
 363
 364     getSrcSpanM                                 `thenM` \ loc ->
 365     returnM (RecordConOut data_con (L loc con_expr) rbinds')
 366
 367 -- The main complication with RecordUpd is that we need to explicitly
 368 -- handle the *non-updated* fields.  Consider:
 369 --
 370 --      data T a b = MkT1 { fa :: a, fb :: b }
 371 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 372 --                 | MkT3 { fd :: a }
 373 --
 374 --      upd :: T a b -> c -> T a c
 375 --      upd t x = t { fb = x}
 376 --
 377 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 378 -- because upd should be equivalent to:
 379 --
 380 --      upd t x = case t of
 381 --                      MkT1 p q -> MkT1 p x
 382 --                      MkT2 a b -> MkT2 p b
 383 --                      MkT3 d   -> error ...
 384 --
 385 -- So we need to give a completely fresh type to the result record,
 386 -- and then constrain it by the fields that are *not* updated ("p" above).
 387 --
 388 -- Note that because MkT3 doesn't contain all the fields being updated,
 389 -- its RHS is simply an error, so it doesn't impose any type constraints
 390 --
 391 -- All this is done in STEP 4 below.
 392
 393 tc_expr expr@(RecordUpd record_expr rbinds) res_ty
 394   = addErrCtxt (recordUpdCtxt   expr)           $
 395
 396         -- STEP 0
 397         -- Check that the field names are really field names
 398     ASSERT( notNull rbinds )
 399     let
 400         field_names = map fst rbinds
 401     in
 402     mappM (tcLookupGlobalId.unLoc) field_names  `thenM` \ sel_ids ->
 403         -- The renamer has already checked that they
 404         -- are all in scope
 405     let
 406         bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name)
 407                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 408                      not (isRecordSelector sel_id)      -- Excludes class ops
 409                    ]
 410     in
 411     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 412
 413         -- STEP 1
 414         -- Figure out the tycon and data cons from the first field name
 415     let
 416                 -- It's OK to use the non-tc splitters here (for a selector)
 417         sel_id : _   = sel_ids
 418         field_lbl    = recordSelectorFieldLabel sel_id  -- We've failed already if
 419         tycon        = fieldLabelTyCon field_lbl        -- it's not a field label
 420         data_cons    = tyConDataCons tycon
 421         tycon_tyvars = tyConTyVars tycon                -- The data cons use the same type vars
 422     in
 423     tcInstTyVars VanillaTv tycon_tyvars         `thenM` \ (_, result_inst_tys, inst_env) ->
 424
 425         -- STEP 2
 426         -- Check that at least one constructor has all the named fields
 427         -- i.e. has an empty set of bad fields returned by badFields
 428     checkTc (any (null . badFields rbinds) data_cons)
 429             (badFieldsUpd rbinds)               `thenM_`
 430
 431         -- STEP 3
 432         -- Typecheck the update bindings.
 433         -- (Do this after checking for bad fields in case there's a field that
 434         --  doesn't match the constructor.)
 435     let
 436         result_record_ty = mkTyConApp tycon result_inst_tys
 437     in
 438     zapExpectedTo res_ty result_record_ty       `thenM_`
 439     tcRecordBinds tycon result_inst_tys rbinds  `thenM` \ rbinds' ->
 440
 441         -- STEP 4
 442         -- Use the un-updated fields to find a vector of booleans saying
 443         -- which type arguments must be the same in updatee and result.
 444         --
 445         -- WARNING: this code assumes that all data_cons in a common tycon
 446         -- have FieldLabels abstracted over the same tyvars.
 447     let
 448         upd_field_lbls      = map recordSelectorFieldLabel (recBindFields rbinds')
 449         con_field_lbls_s    = map dataConFieldLabels data_cons
 450
 451                 -- A constructor is only relevant to this process if
 452                 -- it contains all the fields that are being updated
 453         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 454         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 455
 456         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 457         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 458
 459         mk_inst_ty (tyvar, result_inst_ty)
 460           | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty   -- Same as result type
 461           | otherwise                        = newTyVarTy liftedTypeKind        -- Fresh type
 462     in
 463     mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys ->
 464
 465         -- STEP 5
 466         -- Typecheck the expression to be updated
 467     let
 468         record_ty = mkTyConApp tycon inst_tys
 469     in
 470     tcCheckRho record_expr record_ty            `thenM` \ record_expr' ->
 471
 472         -- STEP 6
 473         -- Figure out the LIE we need.  We have to generate some
 474         -- dictionaries for the data type context, since we are going to
 475         -- do pattern matching over the data cons.
 476         --
 477         -- What dictionaries do we need?
 478         -- We just take the context of the type constructor
 479     let
 480         theta' = substTheta inst_env (tyConTheta tycon)
 481     in
 482     newDicts RecordUpdOrigin theta'     `thenM` \ dicts ->
 483     extendLIEs dicts                    `thenM_`
 484
 485         -- Phew!
 486     returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
 487 \end{code}
 488
 489
 490 %************************************************************************
 491 %*                                                                      *
 492         Arithmetic sequences                    e.g. [a,b..]
 493         and their parallel-array counterparts   e.g. [: a,b.. :]
 494
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 \begin{code}
 499 tc_expr (ArithSeqIn seq@(From expr)) res_ty
 500   = zapToListTy res_ty                          `thenM` \ elt_ty ->
 501     tcCheckRho expr elt_ty                      `thenM` \ expr' ->
 502
 503     newMethodFromName (ArithSeqOrigin seq)
 504                       elt_ty enumFromName       `thenM` \ enum_from ->
 505
 506     returnM (ArithSeqOut (nlHsVar enum_from) (From expr'))
 507
 508 tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 509   = addErrCtxt (arithSeqCtxt in_expr) $
 510     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 511     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 512     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 513     newMethodFromName (ArithSeqOrigin seq)
 514                       elt_ty enumFromThenName           `thenM` \ enum_from_then ->
 515
 516     returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2'))
 517
 518
 519 tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 520   = addErrCtxt (arithSeqCtxt in_expr) $
 521     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 522     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 523     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 524     newMethodFromName (ArithSeqOrigin seq)
 525                       elt_ty enumFromToName             `thenM` \ enum_from_to ->
 526
 527     returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 528
 529 tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 530   = addErrCtxt  (arithSeqCtxt in_expr) $
 531     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 532     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 533     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 534     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 535     newMethodFromName (ArithSeqOrigin seq)
 536                       elt_ty enumFromThenToName         `thenM` \ eft ->
 537
 538     returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 539
 540 tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
 541   = addErrCtxt (parrSeqCtxt in_expr) $
 542     zapToPArrTy  res_ty                                 `thenM`    \ elt_ty ->
 543     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 544     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 545     newMethodFromName (PArrSeqOrigin seq)
 546                       elt_ty enumFromToPName            `thenM` \ enum_from_to ->
 547
 548     returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 549
 550 tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 551   = addErrCtxt  (parrSeqCtxt in_expr) $
 552     zapToPArrTy  res_ty                                 `thenM`    \ elt_ty ->
 553     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 554     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 555     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 556     newMethodFromName (PArrSeqOrigin seq)
 557                       elt_ty enumFromThenToPName        `thenM` \ eft ->
 558
 559     returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 560
 561 tc_expr (PArrSeqIn _) _
 562   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 563     -- the parser shouldn't have generated it and the renamer shouldn't have
 564     -- let it through
 565 \end{code}
 566
 567
 568 %************************************************************************
 569 %*                                                                      *
 570                 Template Haskell
 571 %*                                                                      *
 572 %************************************************************************
 573
 574 \begin{code}
 575 #ifdef GHCI     /* Only if bootstrapped */
 576         -- Rename excludes these cases otherwise
 577 tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 578 tc_expr (HsBracket brack)  res_ty = do  { e <- tcBracket brack res_ty
 579                                         ; return (unLoc e) }
 580 #endif /* GHCI */
 581 \end{code}
 582
 583
 584 %************************************************************************
 585 %*                                                                      *
 586                 Catch-all
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 \begin{code}
 591 tc_expr other _ = pprPanic "tcMonoExpr" (ppr other)
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsection{@tcApp@ typchecks an application}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601 \begin{code}
 602
 603 tcApp :: LHsExpr Name -> [LHsExpr Name]         -- Function and args
 604       -> Expected TcRhoType                     -- Expected result type of application
 605       -> TcM (HsExpr TcId)                              -- Translated fun and args
 606
 607 tcApp (L _ (HsApp e1 e2)) args res_ty
 608   = tcApp e1 (e2:args) res_ty           -- Accumulate the arguments
 609
 610 tcApp fun args res_ty
 611   =     -- First type-check the function
 612     tcInferRho fun                              `thenM` \ (fun', fun_ty) ->
 613
 614     addErrCtxt (wrongArgsCtxt "too many" fun args) (
 615         traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty))      `thenM_`
 616         split_fun_ty fun_ty (length args)
 617     )                                           `thenM` \ (expected_arg_tys, actual_result_ty) ->
 618
 619         -- Unify with expected result before (was: after) type-checking the args
 620         -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty).
 621         -- This is when we might detect a too-few args situation.
 622         -- (One can think of cases when the opposite order would give
 623         -- a better error message.)
 624         -- [March 2003: I'm experimenting with putting this first.  Here's an
 625         --              example where it actually makes a real difference
 626         --    class C t a b | t a -> b
 627         --    instance C Char a Bool
 628         --
 629         --    data P t a = forall b. (C t a b) => MkP b
 630         --    data Q t   = MkQ (forall a. P t a)
 631
 632         --    f1, f2 :: Q Char;
 633         --    f1 = MkQ (MkP True)
 634         --    f2 = MkQ (MkP True :: forall a. P Char a)
 635         --
 636         -- With the change, f1 will type-check, because the 'Char' info from
 637         -- the signature is propagated into MkQ's argument. With the check
 638         -- in the other order, the extra signature in f2 is reqd.]
 639
 640     addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
 641                 (tcSubExp res_ty actual_result_ty)      `thenM` \ co_fn ->
 642
 643         -- Now typecheck the args
 644     mappM (tcArg fun)
 645           (zip3 args expected_arg_tys [1..])    `thenM` \ args' ->
 646
 647     returnM (co_fn <$> unLoc (foldl mkHsApp fun' args'))
 648
 649
 650 -- If an error happens we try to figure out whether the
 651 -- function has been given too many or too few arguments,
 652 -- and say so.
 653 -- The ~(Check...) is because in the Infer case the tcSubExp
 654 -- definitely won't fail, so we can be certain we're in the Check branch
 655 checkArgsCtxt fun args ~(Check expected_res_ty) actual_res_ty tidy_env
 656   = zonkTcType expected_res_ty    `thenM` \ exp_ty' ->
 657     zonkTcType actual_res_ty      `thenM` \ act_ty' ->
 658     let
 659       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 660       (env2, act_ty'') = tidyOpenType env1     act_ty'
 661       (exp_args, _)    = tcSplitFunTys exp_ty''
 662       (act_args, _)    = tcSplitFunTys act_ty''
 663
 664       len_act_args     = length act_args
 665       len_exp_args     = length exp_args
 666
 667       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 668               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 669               | otherwise                   = appCtxt fun args
 670     in
 671     returnM (env2, message)
 672
 673
 674 split_fun_ty :: TcRhoType       -- The type of the function
 675              -> Int             -- Number of arguments
 676              -> TcM ([TcType],  -- Function argument types
 677                      TcType)    -- Function result types
 678
 679 split_fun_ty fun_ty 0
 680   = returnM ([], fun_ty)
 681
 682 split_fun_ty fun_ty n
 683   =     -- Expect the function to have type A->B
 684     unifyFunTy fun_ty           `thenM` \ (arg_ty, res_ty) ->
 685     split_fun_ty res_ty (n-1)   `thenM` \ (arg_tys, final_res_ty) ->
 686     returnM (arg_ty:arg_tys, final_res_ty)
 687 \end{code}
 688
 689 \begin{code}
 690 tcArg :: LHsExpr Name                           -- The function (for error messages)
 691       -> (LHsExpr Name, TcSigmaType, Int)       -- Actual argument and expected arg type
 692       -> TcM (LHsExpr TcId)                     -- Resulting argument
 693
 694 tcArg the_fun (arg, expected_arg_ty, arg_no)
 695   = addErrCtxt (funAppCtxt the_fun arg arg_no) $
 696     tcCheckSigma arg expected_arg_ty
 697 \end{code}
 698
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsection{@tcId@ typchecks an identifier occurrence}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 tcId instantiates an occurrence of an Id.
 707 The instantiate_it loop runs round instantiating the Id.
 708 It has to be a loop because we are now prepared to entertain
 709 types like
 710         f:: forall a. Eq a => forall b. Baz b => tau
 711 We want to instantiate this to
 712         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 713
 714 The -fno-method-sharing flag controls what happens so far as the LIE
 715 is concerned.  The default case is that for an overloaded function we
 716 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 717 something like
 718         f :: Num a => a -> a
 719         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 720 If you specify -fno-method-sharing, the dictionary application
 721 isn't shared, so we get
 722         f :: Num a => a -> a
 723         f = /\a (d:Num a) (x:a) -> (+) a d x x
 724 This gets a bit less sharing, but
 725         a) it's better for RULEs involving overloaded functions
 726         b) perhaps fewer separated lambdas
 727
 728 \begin{code}
 729 tcId :: Name -> TcM (HsExpr TcId, TcRhoType)
 730 tcId name       -- Look up the Id and instantiate its type
 731   =     -- First check whether it's a DataCon
 732         -- Reason: we must not forget to chuck in the
 733         --         constraints from their "silly context"
 734     tcLookup name               `thenM` \ thing ->
 735     case thing of {
 736         AGlobal (ADataCon data_con)  -> inst_data_con data_con
 737     ;   AGlobal (AnId id)            -> loop (HsVar id) (idType id)
 738                 -- A global cannot possibly be ill-staged
 739                 -- nor does it need the 'lifting' treatment
 740
 741     ;   ATcId id th_level proc_level -> tc_local_id id th_level proc_level
 742     ;   other                        -> pprPanic "tcId" (ppr name $$ ppr thing)
 743     }
 744   where
 745
 746 #ifndef GHCI
 747     tc_local_id id th_bind_lvl proc_lvl                 -- Non-TH case
 748         = checkProcLevel id proc_lvl    `thenM_`
 749           loop (HsVar id) (idType id)
 750
 751 #else /* GHCI and TH is on */
 752     tc_local_id id th_bind_lvl proc_lvl                 -- TH case
 753         = checkProcLevel id proc_lvl    `thenM_`
 754
 755         -- Check for cross-stage lifting
 756           getStage                              `thenM` \ use_stage ->
 757           case use_stage of
 758               Brack use_lvl ps_var lie_var
 759                 | use_lvl > th_bind_lvl
 760                 ->      -- E.g. \x -> [| h x |]
 761                 -- We must behave as if the reference to x was
 762
 763                 --      h $(lift x)
 764                 -- We use 'x' itself as the splice proxy, used by
 765                 -- the desugarer to stitch it all back together.
 766                 -- If 'x' occurs many times we may get many identical
 767                 -- bindings of the same splice proxy, but that doesn't
 768                 -- matter, although it's a mite untidy.
 769                 let
 770                     id_ty = idType id
 771                 in
 772                 checkTc (isTauTy id_ty) (polySpliceErr id)      `thenM_`
 773                     -- If x is polymorphic, its occurrence sites might
 774                     -- have different instantiations, so we can't use plain
 775                     -- 'x' as the splice proxy name.  I don't know how to
 776                     -- solve this, and it's probably unimportant, so I'm
 777                     -- just going to flag an error for now
 778
 779                 setLIEVar lie_var       (
 780                 newMethodFromName orig id_ty DsMeta.liftName    `thenM` \ lift ->
 781                         -- Put the 'lift' constraint into the right LIE
 782
 783                 -- Update the pending splices
 784                 readMutVar ps_var                       `thenM` \ ps ->
 785                 writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)   `thenM_`
 786
 787                 returnM (HsVar id, id_ty))
 788
 789               other ->
 790                 checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
 791                 loop (HsVar id) (idType id)
 792 #endif /* GHCI */
 793
 794     loop (HsVar fun_id) fun_ty
 795         | want_method_inst fun_ty
 796         = tcInstType VanillaTv fun_ty           `thenM` \ (tyvars, theta, tau) ->
 797           newMethodWithGivenTy orig fun_id
 798                 (mkTyVarTys tyvars) theta tau   `thenM` \ meth_id ->
 799           loop (HsVar meth_id) tau
 800
 801     loop fun fun_ty
 802         | isSigmaTy fun_ty
 803         = tcInstCall orig fun_ty        `thenM` \ (inst_fn, tau) ->
 804           loop (inst_fn <$> fun) tau
 805
 806         | otherwise
 807         = returnM (fun, fun_ty)
 808
 809         --      Hack Alert (want_method_inst)!
 810         -- If   f :: (%x :: T) => Int -> Int
 811         -- Then if we have two separate calls, (f 3, f 4), we cannot
 812         -- make a method constraint that then gets shared, thus:
 813         --      let m = f %x in (m 3, m 4)
 814         -- because that loses the linearity of the constraint.
 815         -- The simplest thing to do is never to construct a method constraint
 816         -- in the first place that has a linear implicit parameter in it.
 817     want_method_inst fun_ty
 818         | opt_NoMethodSharing = False
 819         | otherwise           = case tcSplitSigmaTy fun_ty of
 820                                   (_,[],_)    -> False  -- Not overloaded
 821                                   (_,theta,_) -> not (any isLinearPred theta)
 822
 823
 824         -- We treat data constructors differently, because we have to generate
 825         -- constraints for their silly theta, which no longer appears in
 826         -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs
 827         -- It's dual to TcPat.tcConstructor
 828     inst_data_con data_con
 829       = tcInstDataCon orig data_con     `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
 830         extendLIEs ex_dicts             `thenM_`
 831         getSrcSpanM                     `thenM` \ loc ->
 832         returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args)
 833                              (map instToId ex_dicts)),
 834                  mkFunTys arg_tys result_ty)
 835         -- ToDo: nasty loc/unloc stuff here
 836
 837     orig = OccurrenceOf name
 838 \end{code}
 839
 840 %************************************************************************
 841 %*                                                                      *
 842 \subsection{Record bindings}
 843 %*                                                                      *
 844 %************************************************************************
 845
 846 Game plan for record bindings
 847 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 848 1. Find the TyCon for the bindings, from the first field label.
 849
 850 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 851
 852 For each binding field = value
 853
 854 3. Instantiate the field type (from the field label) using the type
 855    envt from step 2.
 856
 857 4  Type check the value using tcArg, passing the field type as
 858    the expected argument type.
 859
 860 This extends OK when the field types are universally quantified.
 861
 862
 863 \begin{code}
 864 tcRecordBinds
 865         :: TyCon                -- Type constructor for the record
 866         -> [TcType]             -- Args of this type constructor
 867         -> HsRecordBinds Name
 868         -> TcM (HsRecordBinds TcId)
 869
 870 tcRecordBinds tycon ty_args rbinds
 871   = mappM do_bind rbinds
 872   where
 873     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 874
 875     do_bind (L loc field_lbl_name, rhs)
 876       = addErrCtxt (fieldCtxt field_lbl_name)   $
 877         tcLookupId field_lbl_name               `thenM` \ sel_id ->
 878         let
 879             field_lbl = recordSelectorFieldLabel sel_id
 880             field_ty  = substTy tenv (fieldLabelType field_lbl)
 881         in
 882         ASSERT( isRecordSelector sel_id )
 883                 -- This lookup and assertion will surely succeed, because
 884                 -- we check that the fields are indeed record selectors
 885                 -- before calling tcRecordBinds
 886         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 887                 -- The caller of tcRecordBinds has already checked
 888                 -- that all the fields come from the same type
 889
 890         tcCheckSigma rhs field_ty               `thenM` \ rhs' ->
 891
 892         returnM (L loc sel_id, rhs')
 893
 894 badFields rbinds data_con
 895   = filter (not . (`elem` field_names)) (recBindFields rbinds)
 896   where
 897     field_names = map fieldLabelName (dataConFieldLabels data_con)
 898
 899 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 900 checkMissingFields data_con rbinds
 901   | null field_labels   -- Not declared as a record;
 902                         -- But C{} is still valid if no strict fields
 903   = if any isMarkedStrict field_strs then
 904         -- Illegal if any arg is strict
 905         addErrTc (missingStrictFields data_con [])
 906     else
 907         returnM ()
 908
 909   | otherwise           -- A record
 910   = checkM (null missing_s_fields)
 911            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
 912
 913     doptM Opt_WarnMissingFields         `thenM` \ warn ->
 914     checkM (not (warn && notNull missing_ns_fields))
 915            (warnTc True (missingFields data_con missing_ns_fields))
 916
 917   where
 918     missing_s_fields
 919         = [ fl | (fl, str) <- field_info,
 920                  isMarkedStrict str,
 921                  not (fieldLabelName fl `elem` field_names_used)
 922           ]
 923     missing_ns_fields
 924         = [ fl | (fl, str) <- field_info,
 925                  not (isMarkedStrict str),
 926                  not (fieldLabelName fl `elem` field_names_used)
 927           ]
 928
 929     field_names_used = recBindFields rbinds
 930     field_labels     = dataConFieldLabels data_con
 931
 932     field_info = zipEqual "missingFields"
 933                           field_labels
 934                           field_strs
 935
 936     field_strs = dataConStrictMarks data_con
 937 \end{code}
 938
 939 %************************************************************************
 940 %*                                                                      *
 941 \subsection{@tcCheckRhos@ typechecks a {\em list} of expressions}
 942 %*                                                                      *
 943 %************************************************************************
 944
 945 \begin{code}
 946 tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
 947
 948 tcCheckRhos [] [] = returnM []
 949 tcCheckRhos (expr:exprs) (ty:tys)
 950  = tcCheckRho  expr  ty         `thenM` \ expr' ->
 951    tcCheckRhos exprs tys        `thenM` \ exprs' ->
 952    returnM (expr':exprs')
 953 \end{code}
 954
 955
 956 %************************************************************************
 957 %*                                                                      *
 958 \subsection{Literals}
 959 %*                                                                      *
 960 %************************************************************************
 961
 962 Overloaded literals.
 963
 964 \begin{code}
 965 tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId)
 966 tcLit lit res_ty
 967   = zapExpectedTo res_ty (hsLitType lit)                `thenM_`
 968     returnM (HsLit lit)
 969 \end{code}
 970
 971
 972 %************************************************************************
 973 %*                                                                      *
 974 \subsection{Errors and contexts}
 975 %*                                                                      *
 976 %************************************************************************
 977
 978 Boring and alphabetical:
 979 \begin{code}
 980 arithSeqCtxt expr
 981   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 982
 983 parrSeqCtxt expr
 984   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
 985
 986 caseCtxt expr
 987   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 988
 989 caseScrutCtxt expr
 990   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 991
 992 exprSigCtxt expr
 993   = hang (ptext SLIT("In the type signature of the expression:"))
 994          4 (ppr expr)
 995
 996 exprCtxt expr
 997   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
 998
 999 fieldCtxt field_name
1000   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1001
1002 funAppCtxt fun arg arg_no
1003   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1004                     quotes (ppr fun) <> text ", namely"])
1005          4 (quotes (ppr arg))
1006
1007 listCtxt expr
1008   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1009
1010 parrCtxt expr
1011   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
1012
1013 predCtxt expr
1014   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1015
1016 appCtxt fun args
1017   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1018   where
1019     the_app = foldl mkHsApp fun args    -- Used in error messages
1020
1021 badFieldsUpd rbinds
1022   = hang (ptext SLIT("No constructor has all these fields:"))
1023          4 (pprQuotedList (recBindFields rbinds))
1024
1025 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1026 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1027
1028 notSelector field
1029   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1030
1031 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1032 missingStrictFields con fields
1033   = header <> rest
1034   where
1035     rest | null fields = empty  -- Happens for non-record constructors
1036                                 -- with strict fields
1037          | otherwise   = colon <+> pprWithCommas ppr fields
1038
1039     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1040              ptext SLIT("does not have the required strict field(s)")
1041
1042 missingFields :: DataCon -> [FieldLabel] -> SDoc
1043 missingFields con fields
1044   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1045         <+> pprWithCommas ppr fields
1046
1047 wrongArgsCtxt too_many_or_few fun args
1048   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1049                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1050                     <+> ptext SLIT("arguments in the call"))
1051          4 (parens (ppr the_app))
1052   where
1053     the_app = foldl mkHsApp fun args    -- Used in error messages
1054
1055 #ifdef GHCI
1056 polySpliceErr :: Id -> SDoc
1057 polySpliceErr id
1058   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1059 #endif
1060 \end{code}