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