ghc/compiler/typecheck/TcIfaceSig.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
   5
   6 \begin{code}
   7 module TcIfaceSig ( tcInterfaceSigs,
   8                     tcVar,
   9                     tcCoreExpr,
  10                     tcCoreLamBndrs,
  11                     tcCoreBinds ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HsSyn            ( CoreDecl(..), TyClDecl(..), HsTupCon(..) )
  16 import TcHsSyn          ( TypecheckedCoreBind )
  17 import TcRnTypes
  18 import TcRnMonad
  19 import TcMonoType       ( tcIfaceType, kcHsSigType )
  20 import TcEnv            ( RecTcGblEnv, tcExtendTyVarEnv,
  21                           tcExtendGlobalValEnv,
  22                           tcLookupGlobal_maybe, tcLookupRecId_maybe
  23                         )
  24
  25 import RnHsSyn          ( RenamedCoreDecl, RenamedTyClDecl )
  26 import HsCore
  27 import Literal          ( Literal(..) )
  28 import CoreSyn
  29 import CoreUtils        ( exprType )
  30 import CoreUnfold
  31 import CoreLint         ( lintUnfolding )
  32 import WorkWrap         ( mkWrapper )
  33
  34 import Id               ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe )
  35 import MkId             ( mkFCallId )
  36 import IdInfo
  37 import TyCon            ( tyConDataCons, tyConTyVars )
  38 import DataCon          ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
  39 import Type             ( mkTyVarTys, splitTyConApp )
  40 import TysWiredIn       ( tupleCon )
  41 import Var              ( mkTyVar, tyVarKind )
  42 import Name             ( Name )
  43 import UniqSupply       ( initUs_ )
  44 import Outputable
  45 import Util             ( zipWithEqual, dropList, equalLength )
  46 import HscTypes         ( TyThing(..), typeEnvIds )
  47 import CmdLineOpts      ( DynFlag(..) )
  48 \end{code}
  49
  50 Ultimately, type signatures in interfaces will have pragmatic
  51 information attached, so it is a good idea to have separate code to
  52 check them.
  53
  54 As always, we do not have to worry about user-pragmas in interface
  55 signatures.
  56
  57 \begin{code}
  58 tcInterfaceSigs :: RecTcGblEnv          -- Envt to use when checking unfoldings
  59                 -> [RenamedTyClDecl]    -- Ignore non-sig-decls in these decls
  60                 -> TcM [Id]
  61
  62
  63 tcInterfaceSigs unf_env decls
  64   = sequenceM [ do_one name ty id_infos src_loc
  65               | IfaceSig {tcdName = name, tcdType = ty,
  66                           tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
  67   where
  68     in_scope_vars = typeEnvIds (tcg_type_env unf_env)
  69         -- When we have hi-boot files, an unfolding might refer to
  70         -- something defined in this module, so we must build a
  71         -- suitable in-scope set.  This thunk will only be poked
  72         -- if -dcore-lint is on.
  73
  74     do_one name ty id_infos src_loc
  75       = addSrcLoc src_loc                               $
  76         addErrCtxt (ifaceSigCtxt name)          $
  77         tcIfaceType ty                                  `thenM` \ sigma_ty ->
  78         tcIdInfo unf_env in_scope_vars name
  79                  sigma_ty id_infos                      `thenM` \ id_info ->
  80         returnM (mkVanillaGlobal name sigma_ty id_info)
  81 \end{code}
  82
  83 \begin{code}
  84 tcIdInfo unf_env in_scope_vars name ty info_ins
  85   = foldlM tcPrag init_info info_ins
  86   where
  87     -- Set the CgInfo to something sensible but uninformative before
  88     -- we start; default assumption is that it has CAFs
  89     init_info = hasCafIdInfo
  90
  91     tcPrag info (HsNoCafRefs)   = returnM (info `setCafInfo`     NoCafRefs)
  92
  93     tcPrag info (HsArity arity) =
  94         returnM (info `setArityInfo` arity)
  95
  96     tcPrag info (HsUnfold inline_prag expr)
  97         = tcPragExpr unf_env name in_scope_vars expr    `thenM` \ maybe_expr' ->
  98           let
  99                 -- maybe_expr doesn't get looked at if the unfolding
 100                 -- is never inspected; so the typecheck doesn't even happen
 101                 unfold_info = case maybe_expr' of
 102                                 Nothing    -> noUnfolding
 103                                 Just expr' -> mkTopUnfolding expr'
 104                 info1 = info `setUnfoldingInfo` unfold_info
 105                 info2 = info1 `setInlinePragInfo` inline_prag
 106           in
 107           returnM info2
 108
 109     tcPrag info (HsStrictness strict_info)
 110         = returnM (info `setAllStrictnessInfo` Just strict_info)
 111
 112     tcPrag info (HsWorker nm arity)
 113         = tcWorkerInfo unf_env ty info nm arity
 114 \end{code}
 115
 116 \begin{code}
 117 tcWorkerInfo unf_env ty info worker_name arity
 118   = newUniqueSupply                     `thenM` \ us ->
 119     let
 120         wrap_fn = initUs_ us (mkWrapper ty strict_sig)
 121
 122         -- Watch out! We can't pull on unf_env too eagerly!
 123         info' = case tcLookupRecId_maybe unf_env worker_name of
 124                   Just worker_id ->
 125                     info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
 126                          `setWorkerInfo`     HasWorker worker_id arity
 127
 128                   Nothing -> pprTrace "tcWorkerInfo failed:"
 129                                       (ppr worker_name) info
 130     in
 131     returnM info'
 132   where
 133         -- We are relying here on strictness info always appearing
 134         -- before worker info,  fingers crossed ....
 135       strict_sig = case newStrictnessInfo info of
 136                         Just sig -> sig
 137                         Nothing  -> pprPanic "Worker info but no strictness for" (ppr worker_name)
 138 \end{code}
 139
 140 For unfoldings we try to do the job lazily, so that we never type check
 141 an unfolding that isn't going to be looked at.
 142
 143 \begin{code}
 144 tcPragExpr unf_env name in_scope_vars expr
 145   = forkM doc $
 146     setGblEnv unf_env $
 147
 148     tcCoreExpr expr             `thenM` \ core_expr' ->
 149
 150                 -- Check for type consistency in the unfolding
 151     ifOptM Opt_DoCoreLinting (
 152         getSrcLocM              `thenM` \ src_loc ->
 153         case lintUnfolding src_loc in_scope_vars core_expr' of
 154           Nothing       -> returnM ()
 155           Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg)
 156     )                           `thenM_`
 157
 158    returnM core_expr'
 159   where
 160     doc = text "unfolding of" <+> ppr name
 161 \end{code}
 162
 163
 164 Variables in unfoldings
 165 ~~~~~~~~~~~~~~~~~~~~~~~
 166 ****** Inside here we use only the Global environment, even for locally bound variables.
 167 ****** Why? Because we know all the types and want to bind them to real Ids.
 168
 169 \begin{code}
 170 tcVar :: Name -> TcM Id
 171 tcVar name
 172   = tcLookupGlobal_maybe name   `thenM` \ maybe_id ->
 173     case maybe_id of {
 174         Just (AnId id)  -> returnM id ;
 175         Nothing         -> failWithTc (noDecl name)
 176     }
 177
 178 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 179 \end{code}
 180
 181 UfCore expressions.
 182
 183 \begin{code}
 184 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 185
 186 tcCoreExpr (UfType ty)
 187   = tcIfaceType ty              `thenM` \ ty' ->
 188         -- It might not be of kind type
 189     returnM (Type ty')
 190
 191 tcCoreExpr (UfVar name)
 192   = tcVar name  `thenM` \ id ->
 193     returnM (Var id)
 194
 195 tcCoreExpr (UfLit lit)
 196   = returnM (Lit lit)
 197
 198 -- The dreaded lit-lits are also similar, except here the type
 199 -- is read in explicitly rather than being implicit
 200 tcCoreExpr (UfLitLit lit ty)
 201   = tcIfaceType ty              `thenM` \ ty' ->
 202     returnM (Lit (MachLitLit lit ty'))
 203
 204 tcCoreExpr (UfFCall cc ty)
 205   = tcIfaceType ty      `thenM` \ ty' ->
 206     newUnique           `thenM` \ u ->
 207     returnM (Var (mkFCallId u cc ty'))
 208
 209 tcCoreExpr (UfTuple (HsTupCon boxity arity) args)
 210   = mappM tcCoreExpr args       `thenM` \ args' ->
 211     let
 212         -- Put the missing type arguments back in
 213         con_args = map (Type . exprType) args' ++ args'
 214     in
 215     returnM (mkApps (Var con_id) con_args)
 216   where
 217     con_id = dataConWorkId (tupleCon boxity arity)
 218
 219
 220 tcCoreExpr (UfLam bndr body)
 221   = tcCoreLamBndr bndr          $ \ bndr' ->
 222     tcCoreExpr body             `thenM` \ body' ->
 223     returnM (Lam bndr' body')
 224
 225 tcCoreExpr (UfApp fun arg)
 226   = tcCoreExpr fun              `thenM` \ fun' ->
 227     tcCoreExpr arg              `thenM` \ arg' ->
 228     returnM (App fun' arg')
 229
 230 tcCoreExpr (UfCase scrut case_bndr alts)
 231   = tcCoreExpr scrut                                    `thenM` \ scrut' ->
 232     let
 233         scrut_ty = exprType scrut'
 234         case_bndr' = mkLocalId case_bndr scrut_ty
 235     in
 236     tcExtendGlobalValEnv [case_bndr']   $
 237     mappM (tcCoreAlt scrut_ty) alts     `thenM` \ alts' ->
 238     returnM (Case scrut' case_bndr' alts')
 239
 240 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 241   = tcCoreExpr rhs              `thenM` \ rhs' ->
 242     tcCoreValBndr bndr          $ \ bndr' ->
 243     tcCoreExpr body             `thenM` \ body' ->
 244     returnM (Let (NonRec bndr' rhs') body')
 245
 246 tcCoreExpr (UfLet (UfRec pairs) body)
 247   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 248     mappM tcCoreExpr rhss       `thenM` \ rhss' ->
 249     tcCoreExpr body             `thenM` \ body' ->
 250     returnM (Let (Rec (bndrs' `zip` rhss')) body')
 251   where
 252     (bndrs, rhss) = unzip pairs
 253
 254 tcCoreExpr (UfNote note expr)
 255   = tcCoreExpr expr             `thenM` \ expr' ->
 256     case note of
 257         UfCoerce to_ty -> tcIfaceType to_ty     `thenM` \ to_ty' ->
 258                           returnM (Note (Coerce to_ty'
 259                                                  (exprType expr')) expr')
 260         UfInlineCall   -> returnM (Note InlineCall expr')
 261         UfInlineMe     -> returnM (Note InlineMe   expr')
 262         UfSCC cc       -> returnM (Note (SCC cc)   expr')
 263 \end{code}
 264
 265 \begin{code}
 266 tcCoreLamBndr (UfValBinder name ty) thing_inside
 267   = tcIfaceType ty              `thenM` \ ty' ->
 268     let
 269         id = mkLocalId name ty'
 270     in
 271     tcExtendGlobalValEnv [id] $
 272     thing_inside id
 273
 274 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 275   = let
 276         tyvar = mkTyVar name kind
 277     in
 278     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 279
 280 tcCoreLamBndrs []     thing_inside = thing_inside []
 281 tcCoreLamBndrs (b:bs) thing_inside
 282   = tcCoreLamBndr b     $ \ b' ->
 283     tcCoreLamBndrs bs   $ \ bs' ->
 284     thing_inside (b':bs')
 285
 286 tcCoreValBndr (UfValBinder name ty) thing_inside
 287   = tcIfaceType ty                      `thenM` \ ty' ->
 288     let
 289         id = mkLocalId name ty'
 290     in
 291     tcExtendGlobalValEnv [id] $
 292     thing_inside id
 293
 294 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 295   = mappM tcIfaceType tys               `thenM` \ tys' ->
 296     let
 297         ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
 298     in
 299     tcExtendGlobalValEnv ids $
 300     thing_inside ids
 301   where
 302     names = [name | UfValBinder name _  <- bndrs]
 303     tys   = [ty   | UfValBinder _    ty <- bndrs]
 304 \end{code}
 305
 306 \begin{code}
 307 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 308   = ASSERT( null names )
 309     tcCoreExpr rhs              `thenM` \ rhs' ->
 310     returnM (DEFAULT, [], rhs')
 311
 312 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 313   = ASSERT( null names )
 314     tcCoreExpr rhs              `thenM` \ rhs' ->
 315     returnM (LitAlt lit, [], rhs')
 316
 317 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 318   = ASSERT( null names )
 319     tcCoreExpr rhs              `thenM` \ rhs' ->
 320     tcIfaceType ty              `thenM` \ ty' ->
 321     returnM (LitAlt (MachLitLit str ty'), [], rhs')
 322
 323 -- A case alternative is made quite a bit more complicated
 324 -- by the fact that we omit type annotations because we can
 325 -- work them out.  True enough, but its not that easy!
 326 tcCoreAlt scrut_ty alt@(con, names, rhs)
 327   = tcConAlt con        `thenM` \ con ->
 328     let
 329         ex_tyvars         = dataConExistentialTyVars con
 330         (tycon, inst_tys) = splitTyConApp scrut_ty      -- NB: not tcSplitTyConApp
 331                                                         -- We are looking at Core here
 332         main_tyvars       = tyConTyVars tycon
 333         ex_tyvars'        = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 334         ex_tys'           = mkTyVarTys ex_tyvars'
 335         arg_tys           = dataConArgTys con (inst_tys ++ ex_tys')
 336         id_names          = dropList ex_tyvars names
 337         arg_ids
 338 #ifdef DEBUG
 339                 | not (equalLength id_names arg_tys)
 340                 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 341                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 342                                          ppr arg_tys)
 343                 | otherwise
 344 #endif
 345                 = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
 346     in
 347     ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
 348     tcExtendTyVarEnv ex_tyvars'                 $
 349     tcExtendGlobalValEnv arg_ids                $
 350     tcCoreExpr rhs                                      `thenM` \ rhs' ->
 351     returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 352
 353
 354 tcConAlt :: UfConAlt Name -> TcM DataCon
 355 tcConAlt (UfTupleAlt (HsTupCon boxity arity))
 356   = returnM (tupleCon boxity arity)
 357
 358 tcConAlt (UfDataAlt con_name)
 359   = tcVar con_name      `thenM` \ con_id ->
 360     returnM (case isDataConWrapId_maybe con_id of
 361                     Just con -> con
 362                     Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 363 \end{code}
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{Core decls}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371
 372 \begin{code}
 373 tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind]
 374 -- We don't assume the bindings are in dependency order
 375 -- So first build the environment, then check the RHSs
 376 tcCoreBinds ls = mappM tcCoreBinder ls          `thenM` \ bndrs ->
 377                  tcExtendGlobalValEnv bndrs     $
 378                  mappM (tcCoreBind bndrs) ls
 379
 380 tcCoreBinder (CoreDecl nm ty _ _)
 381  = kcHsSigType ty       `thenM_`
 382    tcIfaceType ty       `thenM` \ ty' ->
 383    returnM (mkLocalId nm ty')
 384
 385 tcCoreBind bndrs (CoreDecl nm _ rhs loc)
 386  = tcVar nm             `thenM` \ id ->
 387    tcCoreExpr rhs       `thenM` \ rhs' ->
 388    let
 389         mb_err = lintUnfolding loc bndrs rhs'
 390    in
 391    (case mb_err of
 392         Just err -> addErr err
 393         Nothing  -> returnM ()) `thenM_`
 394
 395    returnM (id, rhs')
 396 \end{code}
 397
 398
 399 \begin{code}
 400 ifaceSigCtxt sig_name
 401   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 402 \end{code}
 403