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 WorkWrap         ( 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 expr)
  93         = tcPragExpr unf_env name in_scope_vars expr    `thenNF_Tc` \ maybe_expr' ->
  94           let
  95                 -- maybe_expr doesn't get looked at if the unfolding
  96                 -- is never inspected; so the typecheck doesn't even happen
  97                 unfold_info = case maybe_expr' of
  98                                 Nothing    -> noUnfolding
  99                                 Just expr' -> mkTopUnfolding expr'
 100                 info1 = info `setUnfoldingInfo` unfold_info
 101                 info2 = info1 `setInlinePragInfo` inline_prag
 102           in
 103           returnTc info2
 104
 105     tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
 106         = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
 107
 108     tcPrag info (HsWorker nm)
 109         = tcWorkerInfo unf_env ty info nm
 110 \end{code}
 111
 112 \begin{code}
 113 tcWorkerInfo unf_env ty info worker_name
 114   | not (hasArity arity_info)
 115   = pprPanic "Worker with no arity info" (ppr worker_name)
 116
 117   | otherwise
 118   = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
 119     let
 120         -- Watch out! We can't pull on unf_env too eagerly!
 121         info' = case explicitLookupValue unf_env worker_name of
 122                         Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
 123                                                `setWorkerInfo`     Just worker_id
 124
 125                         Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
 126     in
 127     returnTc info'
 128   where
 129         -- We are relying here on arity, cpr and strictness info always appearing
 130         -- before worker info,  fingers crossed ....
 131       arity_info = arityInfo info
 132       arity      = arityLowerBound arity_info
 133       cpr_info   = cprInfo info
 134       demands    = case strictnessInfo info of
 135                         StrictnessInfo d _ -> d
 136                         _                  -> take arity (repeat wwLazy)        -- Noncommittal
 137 \end{code}
 138
 139 For unfoldings we try to do the job lazily, so that we never type check
 140 an unfolding that isn't going to be looked at.
 141
 142 \begin{code}
 143 tcPragExpr unf_env name in_scope_vars expr
 144   = tcDelay unf_env doc $
 145         tcCoreExpr expr         `thenTc` \ core_expr' ->
 146
 147                 -- Check for type consistency in the unfolding
 148         tcGetSrcLoc             `thenNF_Tc` \ src_loc ->
 149         case lintUnfolding src_loc in_scope_vars core_expr' of
 150           Nothing       -> returnTc core_expr'
 151           Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
 152   where
 153     doc = text "unfolding of" <+> ppr name
 154
 155 tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
 156 tcDelay unf_env doc thing_inside
 157   = forkNF_Tc (
 158         recoverNF_Tc bad_value (
 159                 tcSetValueEnv unf_env thing_inside      `thenTc` \ r ->
 160                 returnTc (Just r)
 161     ))
 162   where
 163         -- The trace tells what wasn't available, for the benefit of
 164         -- compiler hackers who want to improve it!
 165     bad_value = getErrsTc               `thenNF_Tc` \ (warns,errs) ->
 166                 returnNF_Tc (pprTrace "Failed:"
 167                                          (hang doc 4 (pprBagOfErrors errs))
 168                                          Nothing)
 169 \end{code}
 170
 171
 172 Variables in unfoldings
 173 ~~~~~~~~~~~~~~~~~~~~~~~
 174 ****** Inside here we use only the Global environment, even for locally bound variables.
 175 ****** Why? Because we know all the types and want to bind them to real Ids.
 176
 177 \begin{code}
 178 tcVar :: Name -> TcM s Id
 179 tcVar name
 180   = tcLookupValueMaybe name     `thenNF_Tc` \ maybe_id ->
 181     case maybe_id of {
 182         Just id -> returnTc id;
 183         Nothing -> failWithTc (noDecl name)
 184     }
 185
 186 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 187 \end{code}
 188
 189 UfCore expressions.
 190
 191 \begin{code}
 192 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
 193
 194 tcCoreExpr (UfType ty)
 195   = tcHsTypeKind ty     `thenTc` \ (_, ty') ->
 196         -- It might not be of kind type
 197     returnTc (Type ty')
 198
 199 tcCoreExpr (UfVar name)
 200   = tcVar name  `thenTc` \ id ->
 201     returnTc (Var id)
 202
 203 tcCoreExpr (UfCon con args)
 204   = tcUfCon con                 `thenTc` \ con' ->
 205     mapTc tcCoreExpr args       `thenTc` \ args' ->
 206     returnTc (Con con' args')
 207
 208 tcCoreExpr (UfTuple name args)
 209   = tcUfDataCon name            `thenTc` \ con ->
 210     mapTc tcCoreExpr args       `thenTc` \ args' ->
 211     let
 212         -- Put the missing type arguments back in
 213         con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
 214     in
 215     returnTc (Con con con_args)
 216
 217 tcCoreExpr (UfLam bndr body)
 218   = tcCoreLamBndr bndr          $ \ bndr' ->
 219     tcCoreExpr body             `thenTc` \ body' ->
 220     returnTc (Lam bndr' body')
 221
 222 tcCoreExpr (UfApp fun arg)
 223   = tcCoreExpr fun              `thenTc` \ fun' ->
 224     tcCoreExpr arg              `thenTc` \ arg' ->
 225     returnTc (App fun' arg')
 226
 227 tcCoreExpr (UfCase scrut case_bndr alts)
 228   = tcCoreExpr scrut                                    `thenTc` \ scrut' ->
 229     let
 230         scrut_ty = coreExprType scrut'
 231         case_bndr' = mkVanillaId case_bndr scrut_ty
 232     in
 233     tcExtendGlobalValEnv [case_bndr']   $
 234     mapTc (tcCoreAlt scrut_ty) alts     `thenTc` \ alts' ->
 235     returnTc (Case scrut' case_bndr' alts')
 236
 237 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 238   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 239     tcCoreValBndr bndr          $ \ bndr' ->
 240     tcCoreExpr body             `thenTc` \ body' ->
 241     returnTc (Let (NonRec bndr' rhs') body')
 242
 243 tcCoreExpr (UfLet (UfRec pairs) body)
 244   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 245     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 246     tcCoreExpr body             `thenTc` \ body' ->
 247     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 248   where
 249     (bndrs, rhss) = unzip pairs
 250
 251 tcCoreExpr (UfNote note expr)
 252   = tcCoreExpr expr             `thenTc` \ expr' ->
 253     case note of
 254         UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
 255                           returnTc (Note (Coerce (unUsgTy to_ty')
 256                                                  (unUsgTy (coreExprType expr'))) expr')
 257         UfInlineCall   -> returnTc (Note InlineCall expr')
 258         UfInlineMe     -> returnTc (Note InlineMe   expr')
 259         UfSCC cc       -> returnTc (Note (SCC cc)   expr')
 260
 261 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 262 tcCoreNote UfInlineCall = returnTc InlineCall
 263
 264
 265 -- rationalTy isn't built in so, we have to construct it
 266 -- (the "ty" part of the incoming literal is simply bottom)
 267 tcUfCon (UfLitCon (NoRepRational lit _))
 268   = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 269     let
 270         rational_ty  = mkSynTy rational_tycon []
 271     in
 272     returnTc (Literal (NoRepRational lit rational_ty))
 273
 274 -- Similarly for integers and strings, except that they are wired in
 275 tcUfCon (UfLitCon (NoRepInteger lit _))
 276   = returnTc (Literal (NoRepInteger lit integerTy))
 277 tcUfCon (UfLitCon (NoRepStr lit _))
 278   = returnTc (Literal (NoRepStr lit stringTy))
 279
 280 tcUfCon (UfLitCon other_lit)
 281   = returnTc (Literal other_lit)
 282
 283 -- The dreaded lit-lits are also similar, except here the type
 284 -- is read in explicitly rather than being implicit
 285 tcUfCon (UfLitLitCon lit ty)
 286   = tcHsType ty         `thenTc` \ ty' ->
 287     returnTc (Literal (MachLitLit lit ty'))
 288
 289 tcUfCon (UfDataCon name) = tcUfDataCon name
 290
 291 tcUfCon (UfPrimOp name)
 292   = tcVar name          `thenTc` \ op_id ->
 293     case isPrimitiveId_maybe op_id of
 294         Just op -> returnTc (PrimOp op)
 295         Nothing -> failWithTc (badPrimOp name)
 296
 297 tcUfCon (UfCCallOp str is_dyn casm gc)
 298   = case is_dyn of
 299        True  ->
 300           tcGetUnique `thenNF_Tc` \ u ->
 301           returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
 302        False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
 303
 304 tcUfDataCon name
 305   = tcVar name          `thenTc` \ con_id ->
 306     case isDataConId_maybe con_id of
 307         Just con -> returnTc (DataCon con)
 308         Nothing  -> failWithTc (badCon name)
 309 \end{code}
 310
 311 \begin{code}
 312 tcCoreLamBndr (UfValBinder name ty) thing_inside
 313   = tcHsType ty                 `thenTc` \ ty' ->
 314     let
 315         id = mkVanillaId name ty'
 316     in
 317     tcExtendGlobalValEnv [id] $
 318     thing_inside id
 319
 320 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 321   = let
 322         tyvar = mkTyVar name kind
 323     in
 324     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 325
 326 tcCoreLamBndrs []     thing_inside = thing_inside []
 327 tcCoreLamBndrs (b:bs) thing_inside
 328   = tcCoreLamBndr b     $ \ b' ->
 329     tcCoreLamBndrs bs   $ \ bs' ->
 330     thing_inside (b':bs')
 331
 332 tcCoreValBndr (UfValBinder name ty) thing_inside
 333   = tcHsType ty                 `thenTc` \ ty' ->
 334     let
 335         id = mkVanillaId name ty'
 336     in
 337     tcExtendGlobalValEnv [id] $
 338     thing_inside id
 339
 340 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 341   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 342     let
 343         ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
 344     in
 345     tcExtendGlobalValEnv ids $
 346     thing_inside ids
 347   where
 348     names = [name | UfValBinder name _  <- bndrs]
 349     tys   = [ty   | UfValBinder _    ty <- bndrs]
 350 \end{code}
 351
 352 \begin{code}
 353 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 354   = ASSERT( null names )
 355     tcCoreExpr rhs              `thenTc` \ rhs' ->
 356     returnTc (DEFAULT, [], rhs')
 357
 358 tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
 359   = ASSERT( null names )
 360     tcCoreExpr rhs              `thenTc` \ rhs' ->
 361     returnTc (Literal lit, [], rhs')
 362
 363 tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
 364   = ASSERT( null names )
 365     tcCoreExpr rhs              `thenTc` \ rhs' ->
 366     tcHsType ty                 `thenTc` \ ty' ->
 367     returnTc (Literal (MachLitLit str ty'), [], rhs')
 368
 369 -- A case alternative is made quite a bit more complicated
 370 -- by the fact that we omit type annotations because we can
 371 -- work them out.  True enough, but its not that easy!
 372 tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
 373   = tcVar con_name              `thenTc` \ con_id ->
 374     let
 375         con                     = case isDataConId_maybe con_id of
 376                                         Just con -> con
 377                                         Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 378
 379         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 380
 381         (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 382         ex_tyvars'              = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 383         ex_tys'                 = mkTyVarTys ex_tyvars'
 384         arg_tys                 = dataConArgTys con (inst_tys ++ ex_tys')
 385         id_names                = drop (length ex_tyvars) names
 386         arg_ids
 387 #ifdef DEBUG
 388                 | length id_names /= length arg_tys
 389                 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
 390                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 391                                          ppr arg_tys)
 392                 | otherwise
 393 #endif
 394                 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
 395     in
 396     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 397     tcExtendTyVarEnv ex_tyvars'                 $
 398     tcExtendGlobalValEnv arg_ids                $
 399     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 400     returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
 401 \end{code}
 402
 403 \begin{code}
 404 ifaceSigCtxt sig_name
 405   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 406 \end{code}
 407