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, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), IfaceSig(..) )
  12 import TcMonad
  13 import TcMonoType       ( tcHsType, tcHsTypeKind,
  14                                 -- NB: all the tyars in interface files are kinded,
  15                                 -- so tcHsType will do the Right Thing without
  16                                 -- having to mess about with zonking
  17                           tcExtendTyVarScope
  18                         )
  19 import TcEnv            ( ValueEnv, tcExtendTyVarEnv,
  20                           tcExtendGlobalValEnv, tcSetValueEnv,
  21                           tcLookupTyConByKey, tcLookupValueMaybe,
  22                           explicitLookupValue, badCon, badPrimOp, valueEnvIds
  23                         )
  24 import TcType           ( TcKind, kindToTcKind )
  25
  26 import RnHsSyn          ( RenamedHsDecl )
  27 import HsCore
  28 import CallConv         ( cCallConv )
  29 import Const            ( Con(..), Literal(..) )
  30 import CoreSyn
  31 import CoreUtils        ( coreExprType )
  32 import CoreUnfold
  33 import CoreLint         ( lintUnfolding )
  34 import WwLib            ( mkWrapper )
  35 import PrimOp           ( PrimOp(..) )
  36
  37 import Id               ( Id, mkId, mkVanillaId,
  38                           isPrimitiveId_maybe, isDataConId_maybe
  39                         )
  40 import IdInfo
  41 import DataCon          ( dataConSig, dataConArgTys )
  42 import Type             ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
  43 import Var              ( IdOrTyVar, mkTyVar, tyVarKind )
  44 import VarEnv
  45 import Name             ( Name, NamedThing(..), isLocallyDefined )
  46 import Unique           ( rationalTyConKey )
  47 import TysWiredIn       ( integerTy, stringTy )
  48 import Demand           ( wwLazy )
  49 import ErrUtils         ( pprBagOfErrors )
  50 import Maybes           ( maybeToBool, MaybeErr(..) )
  51 import Outputable
  52 import Util             ( zipWithEqual )
  53 \end{code}
  54
  55 Ultimately, type signatures in interfaces will have pragmatic
  56 information attached, so it is a good idea to have separate code to
  57 check them.
  58
  59 As always, we do not have to worry about user-pragmas in interface
  60 signatures.
  61
  62 \begin{code}
  63 tcInterfaceSigs :: ValueEnv             -- Envt to use when checking unfoldings
  64                 -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
  65                 -> TcM s [Id]
  66
  67
  68 tcInterfaceSigs unf_env decls
  69   = listTc [ do_one name ty id_infos src_loc
  70            | SigD (IfaceSig name ty id_infos src_loc) <- decls]
  71   where
  72     in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
  73
  74     do_one name ty id_infos src_loc
  75       = tcAddSrcLoc src_loc                             $
  76         tcAddErrCtxt (ifaceSigCtxt name)                $
  77         tcHsType ty                                     `thenTc` \ sigma_ty ->
  78         tcIdInfo unf_env in_scope_vars name
  79                  sigma_ty vanillaIdInfo id_infos        `thenTc` \ id_info ->
  80         returnTc (mkId name sigma_ty id_info)
  81 \end{code}
  82
  83 \begin{code}
  84 tcIdInfo unf_env in_scope_vars name ty info info_ins
  85   = foldlTc tcPrag vanillaIdInfo info_ins
  86   where
  87     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
  88     tcPrag info (HsUpdate upd)  = returnTc (info `setUpdateInfo` upd)
  89     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`    NoCafRefs)
  90     tcPrag info (HsCprInfo cpr_info)     = returnTc (info `setCprInfo` cpr_info)
  91
  92     tcPrag info (HsUnfold inline_prag maybe_expr)
  93         = (case maybe_expr of
  94                 Just expr -> tcPragExpr unf_env name in_scope_vars expr
  95                 Nothing   -> returnNF_Tc Nothing
  96           )                                     `thenNF_Tc` \ maybe_expr' ->
  97           let
  98                 -- maybe_expr doesn't get looked at if the unfolding
  99                 -- is never inspected; so the typecheck doesn't even happen
 100                 unfold_info = case maybe_expr' of
 101                                 Nothing    -> noUnfolding
 102                                 Just expr' -> mkUnfolding expr'
 103                 info1 = info `setUnfoldingInfo` unfold_info
 104                 info2 = info1 `setInlinePragInfo` inline_prag
 105           in
 106           returnTc info2
 107
 108     tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
 109         = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
 110
 111     tcPrag info (HsWorker nm)
 112         = tcWorkerInfo unf_env ty info nm
 113 \end{code}
 114
 115 \begin{code}
 116 tcWorkerInfo unf_env ty info worker_name
 117   | not (hasArity arity_info)
 118   = pprPanic "Worker with no arity info" (ppr worker_name)
 119
 120   | otherwise
 121   = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
 122     let
 123         -- Watch out! We can't pull on unf_env too eagerly!
 124         info' = case explicitLookupValue unf_env worker_name of
 125                         Just worker_id -> info `setUnfoldingInfo`  mkUnfolding (wrap_fn worker_id)
 126                                                `setWorkerInfo`     Just worker_id
 127
 128                         Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
 129     in
 130     returnTc info'
 131   where
 132         -- We are relying here on arity, cpr and strictness info always appearing
 133         -- before worker info,  fingers crossed ....
 134       arity_info = arityInfo info
 135       arity      = arityLowerBound arity_info
 136       cpr_info   = cprInfo info
 137       demands    = case strictnessInfo info of
 138                         StrictnessInfo d _ -> d
 139                         _                  -> repeat wwLazy     -- Noncommittal
 140 \end{code}
 141
 142 For unfoldings we try to do the job lazily, so that we never type check
 143 an unfolding that isn't going to be looked at.
 144
 145 \begin{code}
 146 tcPragExpr unf_env name in_scope_vars expr
 147   = tcDelay unf_env doc $
 148         tcCoreExpr expr         `thenTc` \ core_expr' ->
 149
 150                 -- Check for type consistency in the unfolding
 151         tcGetSrcLoc             `thenNF_Tc` \ src_loc ->
 152         case lintUnfolding src_loc in_scope_vars core_expr' of
 153           Nothing       -> returnTc core_expr'
 154           Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
 155   where
 156     doc = text "unfolding of" <+> ppr name
 157
 158 tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
 159 tcDelay unf_env doc thing_inside
 160   = forkNF_Tc (
 161         recoverNF_Tc bad_value (
 162                 tcSetValueEnv unf_env thing_inside      `thenTc` \ r ->
 163                 returnTc (Just r)
 164     ))
 165   where
 166         -- The trace tells what wasn't available, for the benefit of
 167         -- compiler hackers who want to improve it!
 168     bad_value = getErrsTc               `thenNF_Tc` \ (warns,errs) ->
 169                 returnNF_Tc (pprTrace "Failed:"
 170                                          (hang doc 4 (pprBagOfErrors errs))
 171                                          Nothing)
 172 \end{code}
 173
 174
 175 Variables in unfoldings
 176 ~~~~~~~~~~~~~~~~~~~~~~~
 177 ****** Inside here we use only the Global environment, even for locally bound variables.
 178 ****** Why? Because we know all the types and want to bind them to real Ids.
 179
 180 \begin{code}
 181 tcVar :: Name -> TcM s Id
 182 tcVar name
 183   = tcLookupValueMaybe name     `thenNF_Tc` \ maybe_id ->
 184     case maybe_id of {
 185         Just id -> returnTc id;
 186         Nothing -> failWithTc (noDecl name)
 187     }
 188
 189 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 190 \end{code}
 191
 192 UfCore expressions.
 193
 194 \begin{code}
 195 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
 196
 197 tcCoreExpr (UfType ty)
 198   = tcHsTypeKind ty     `thenTc` \ (_, ty') ->
 199         -- It might not be of kind type
 200     returnTc (Type ty')
 201
 202 tcCoreExpr (UfVar name)
 203   = tcVar name  `thenTc` \ id ->
 204     returnTc (Var id)
 205
 206 tcCoreExpr (UfCon con args)
 207   = tcUfCon con                 `thenTc` \ con' ->
 208     mapTc tcCoreExpr args       `thenTc` \ args' ->
 209     returnTc (Con con' args')
 210
 211 tcCoreExpr (UfTuple name args)
 212   = tcUfDataCon name            `thenTc` \ con ->
 213     mapTc tcCoreExpr args       `thenTc` \ args' ->
 214     let
 215         -- Put the missing type arguments back in
 216         con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
 217     in
 218     returnTc (Con con con_args)
 219
 220 tcCoreExpr (UfLam bndr body)
 221   = tcCoreLamBndr bndr          $ \ bndr' ->
 222     tcCoreExpr body             `thenTc` \ body' ->
 223     returnTc (Lam bndr' body')
 224
 225 tcCoreExpr (UfApp fun arg)
 226   = tcCoreExpr fun              `thenTc` \ fun' ->
 227     tcCoreExpr arg              `thenTc` \ arg' ->
 228     returnTc (App fun' arg')
 229
 230 tcCoreExpr (UfCase scrut case_bndr alts)
 231   = tcCoreExpr scrut                                    `thenTc` \ scrut' ->
 232     let
 233         scrut_ty = coreExprType scrut'
 234         case_bndr' = mkVanillaId case_bndr scrut_ty
 235     in
 236     tcExtendGlobalValEnv [case_bndr']   $
 237     mapTc (tcCoreAlt scrut_ty) alts     `thenTc` \ alts' ->
 238     returnTc (Case scrut' case_bndr' alts')
 239
 240 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 241   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 242     tcCoreValBndr bndr          $ \ bndr' ->
 243     tcCoreExpr body             `thenTc` \ body' ->
 244     returnTc (Let (NonRec bndr' rhs') body')
 245
 246 tcCoreExpr (UfLet (UfRec pairs) body)
 247   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 248     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 249     tcCoreExpr body             `thenTc` \ body' ->
 250     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 251   where
 252     (bndrs, rhss) = unzip pairs
 253
 254 tcCoreExpr (UfNote note expr)
 255   = tcCoreExpr expr             `thenTc` \ expr' ->
 256     case note of
 257         UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
 258                           returnTc (Note (Coerce (unUsgTy to_ty')
 259                                                  (unUsgTy (coreExprType expr'))) expr')
 260         UfInlineCall   -> returnTc (Note InlineCall expr')
 261         UfInlineMe     -> returnTc (Note InlineMe   expr')
 262         UfSCC cc       -> returnTc (Note (SCC cc)   expr')
 263
 264 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 265 tcCoreNote UfInlineCall = returnTc InlineCall
 266
 267
 268 -- rationalTy isn't built in so, we have to construct it
 269 -- (the "ty" part of the incoming literal is simply bottom)
 270 tcUfCon (UfLitCon (NoRepRational lit _))
 271   = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 272     let
 273         rational_ty  = mkSynTy rational_tycon []
 274     in
 275     returnTc (Literal (NoRepRational lit rational_ty))
 276
 277 -- Similarly for integers and strings, except that they are wired in
 278 tcUfCon (UfLitCon (NoRepInteger lit _))
 279   = returnTc (Literal (NoRepInteger lit integerTy))
 280 tcUfCon (UfLitCon (NoRepStr lit _))
 281   = returnTc (Literal (NoRepStr lit stringTy))
 282
 283 tcUfCon (UfLitCon other_lit)
 284   = returnTc (Literal other_lit)
 285
 286 -- The dreaded lit-lits are also similar, except here the type
 287 -- is read in explicitly rather than being implicit
 288 tcUfCon (UfLitLitCon lit ty)
 289   = tcHsType ty         `thenTc` \ ty' ->
 290     returnTc (Literal (MachLitLit lit ty'))
 291
 292 tcUfCon (UfDataCon name) = tcUfDataCon name
 293
 294 tcUfCon (UfPrimOp name)
 295   = tcVar name          `thenTc` \ op_id ->
 296     case isPrimitiveId_maybe op_id of
 297         Just op -> returnTc (PrimOp op)
 298         Nothing -> failWithTc (badPrimOp name)
 299
 300 tcUfCon (UfCCallOp str is_dyn casm gc)
 301   = case is_dyn of
 302        True  ->
 303           tcGetUnique `thenNF_Tc` \ u ->
 304           returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
 305        False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
 306
 307 tcUfDataCon name
 308   = tcVar name          `thenTc` \ con_id ->
 309     case isDataConId_maybe con_id of
 310         Just con -> returnTc (DataCon con)
 311         Nothing  -> failWithTc (badCon name)
 312 \end{code}
 313
 314 \begin{code}
 315 tcCoreLamBndr (UfValBinder name ty) thing_inside
 316   = tcHsType ty                 `thenTc` \ ty' ->
 317     let
 318         id = mkVanillaId name ty'
 319     in
 320     tcExtendGlobalValEnv [id] $
 321     thing_inside id
 322
 323 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 324   = let
 325         tyvar = mkTyVar name kind
 326     in
 327     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 328
 329 tcCoreLamBndrs []     thing_inside = thing_inside []
 330 tcCoreLamBndrs (b:bs) thing_inside
 331   = tcCoreLamBndr b     $ \ b' ->
 332     tcCoreLamBndrs bs   $ \ bs' ->
 333     thing_inside (b':bs')
 334
 335 tcCoreValBndr (UfValBinder name ty) thing_inside
 336   = tcHsType ty                 `thenTc` \ ty' ->
 337     let
 338         id = mkVanillaId name ty'
 339     in
 340     tcExtendGlobalValEnv [id] $
 341     thing_inside id
 342
 343 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 344   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 345     let
 346         ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
 347     in
 348     tcExtendGlobalValEnv ids $
 349     thing_inside ids
 350   where
 351     names = [name | UfValBinder name _  <- bndrs]
 352     tys   = [ty   | UfValBinder _    ty <- bndrs]
 353 \end{code}
 354
 355 \begin{code}
 356 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 357   = ASSERT( null names )
 358     tcCoreExpr rhs              `thenTc` \ rhs' ->
 359     returnTc (DEFAULT, [], rhs')
 360
 361 tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
 362   = ASSERT( null names )
 363     tcCoreExpr rhs              `thenTc` \ rhs' ->
 364     returnTc (Literal lit, [], rhs')
 365
 366 tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
 367   = ASSERT( null names )
 368     tcCoreExpr rhs              `thenTc` \ rhs' ->
 369     tcHsType ty                 `thenTc` \ ty' ->
 370     returnTc (Literal (MachLitLit str ty'), [], rhs')
 371
 372 -- A case alternative is made quite a bit more complicated
 373 -- by the fact that we omit type annotations because we can
 374 -- work them out.  True enough, but its not that easy!
 375 tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
 376   = tcVar con_name              `thenTc` \ con_id ->
 377     let
 378         con                     = case isDataConId_maybe con_id of
 379                                         Just con -> con
 380                                         Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 381
 382         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 383
 384         (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 385         ex_tyvars'              = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 386         ex_tys'                 = mkTyVarTys ex_tyvars'
 387         arg_tys                 = dataConArgTys con (inst_tys ++ ex_tys')
 388         id_names                = drop (length ex_tyvars) names
 389         arg_ids
 390 #ifdef DEBUG
 391                 | length id_names /= length arg_tys
 392                 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
 393                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 394                                          ppr arg_tys)
 395                 | otherwise
 396 #endif
 397                 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
 398     in
 399     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 400     tcExtendTyVarEnv ex_tyvars'                 $
 401     tcExtendGlobalValEnv arg_ids                $
 402     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 403     returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
 404 \end{code}
 405
 406 \begin{code}
 407 ifaceSigCtxt sig_name
 408   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 409 \end{code}
 410