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                           tcLookupValueMaybe,
  22                           explicitLookupValue, badCon, badPrimOp, valueEnvIds
  23                         )
  24 import TcType           ( TcKind, kindToTcKind )
  25
  26 import RnHsSyn          ( RenamedHsDecl )
  27 import HsCore
  28 import Literal          ( Literal(..) )
  29 import CoreSyn
  30 import CoreUtils        ( exprType )
  31 import CoreUnfold
  32 import CoreLint         ( lintUnfolding )
  33 import WorkWrap         ( mkWrapper )
  34 import PrimOp           ( PrimOp(..), CCall(..), CCallTarget(..) )
  35
  36 import Id               ( Id, mkId, mkVanillaId,
  37                           isDataConWrapId_maybe
  38                         )
  39 import MkId             ( mkCCallOpId )
  40 import IdInfo
  41 import DataCon          ( dataConSig, dataConArgTys )
  42 import Type             ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy )
  43 import Var              ( 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       = returnTc (info `setCprInfo`    ReturnsCPR)
  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 res_bot 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`     HasWorker worker_id arity
 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, res_bot)    = case strictnessInfo info of
 135                                 StrictnessInfo d r -> (d,r)
 136                                 _                  -> (take arity (repeat wwLazy),False)        -- 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 (UfLit lit)
 204   = returnTc (Lit lit)
 205
 206 -- The dreaded lit-lits are also similar, except here the type
 207 -- is read in explicitly rather than being implicit
 208 tcCoreExpr (UfLitLit lit ty)
 209   = tcHsType ty         `thenTc` \ ty' ->
 210     returnTc (Lit (MachLitLit lit ty'))
 211
 212 tcCoreExpr (UfCCall cc ty)
 213   = tcHsType ty         `thenTc` \ ty' ->
 214     tcGetUnique         `thenNF_Tc` \ u ->
 215     returnTc (Var (mkCCallOpId u cc ty'))
 216
 217 tcCoreExpr (UfTuple name args)
 218   = tcVar name                  `thenTc` \ con_id ->
 219     mapTc tcCoreExpr args       `thenTc` \ args' ->
 220     let
 221         -- Put the missing type arguments back in
 222         con_args = map (Type . unUsgTy . exprType) args' ++ args'
 223     in
 224     returnTc (mkApps (Var con_id) con_args)
 225
 226 tcCoreExpr (UfLam bndr body)
 227   = tcCoreLamBndr bndr          $ \ bndr' ->
 228     tcCoreExpr body             `thenTc` \ body' ->
 229     returnTc (Lam bndr' body')
 230
 231 tcCoreExpr (UfApp fun arg)
 232   = tcCoreExpr fun              `thenTc` \ fun' ->
 233     tcCoreExpr arg              `thenTc` \ arg' ->
 234     returnTc (App fun' arg')
 235
 236 tcCoreExpr (UfCase scrut case_bndr alts)
 237   = tcCoreExpr scrut                                    `thenTc` \ scrut' ->
 238     let
 239         scrut_ty = exprType scrut'
 240         case_bndr' = mkVanillaId case_bndr scrut_ty
 241     in
 242     tcExtendGlobalValEnv [case_bndr']   $
 243     mapTc (tcCoreAlt scrut_ty) alts     `thenTc` \ alts' ->
 244     returnTc (Case scrut' case_bndr' alts')
 245
 246 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 247   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 248     tcCoreValBndr bndr          $ \ bndr' ->
 249     tcCoreExpr body             `thenTc` \ body' ->
 250     returnTc (Let (NonRec bndr' rhs') body')
 251
 252 tcCoreExpr (UfLet (UfRec pairs) body)
 253   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 254     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 255     tcCoreExpr body             `thenTc` \ body' ->
 256     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 257   where
 258     (bndrs, rhss) = unzip pairs
 259
 260 tcCoreExpr (UfNote note expr)
 261   = tcCoreExpr expr             `thenTc` \ expr' ->
 262     case note of
 263         UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
 264                           returnTc (Note (Coerce (unUsgTy to_ty')
 265                                                  (unUsgTy (exprType expr'))) expr')
 266         UfInlineCall   -> returnTc (Note InlineCall expr')
 267         UfInlineMe     -> returnTc (Note InlineMe   expr')
 268         UfSCC cc       -> returnTc (Note (SCC cc)   expr')
 269
 270 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 271 tcCoreNote UfInlineCall = returnTc InlineCall
 272 \end{code}
 273
 274 \begin{code}
 275 tcCoreLamBndr (UfValBinder name ty) thing_inside
 276   = tcHsType ty                 `thenTc` \ ty' ->
 277     let
 278         id = mkVanillaId name ty'
 279     in
 280     tcExtendGlobalValEnv [id] $
 281     thing_inside id
 282
 283 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 284   = let
 285         tyvar = mkTyVar name kind
 286     in
 287     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 288
 289 tcCoreLamBndrs []     thing_inside = thing_inside []
 290 tcCoreLamBndrs (b:bs) thing_inside
 291   = tcCoreLamBndr b     $ \ b' ->
 292     tcCoreLamBndrs bs   $ \ bs' ->
 293     thing_inside (b':bs')
 294
 295 tcCoreValBndr (UfValBinder name ty) thing_inside
 296   = tcHsType ty                 `thenTc` \ ty' ->
 297     let
 298         id = mkVanillaId name ty'
 299     in
 300     tcExtendGlobalValEnv [id] $
 301     thing_inside id
 302
 303 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 304   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 305     let
 306         ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
 307     in
 308     tcExtendGlobalValEnv ids $
 309     thing_inside ids
 310   where
 311     names = [name | UfValBinder name _  <- bndrs]
 312     tys   = [ty   | UfValBinder _    ty <- bndrs]
 313 \end{code}
 314
 315 \begin{code}
 316 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 317   = ASSERT( null names )
 318     tcCoreExpr rhs              `thenTc` \ rhs' ->
 319     returnTc (DEFAULT, [], rhs')
 320
 321 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 322   = ASSERT( null names )
 323     tcCoreExpr rhs              `thenTc` \ rhs' ->
 324     returnTc (LitAlt lit, [], rhs')
 325
 326 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 327   = ASSERT( null names )
 328     tcCoreExpr rhs              `thenTc` \ rhs' ->
 329     tcHsType ty                 `thenTc` \ ty' ->
 330     returnTc (LitAlt (MachLitLit str ty'), [], rhs')
 331
 332 -- A case alternative is made quite a bit more complicated
 333 -- by the fact that we omit type annotations because we can
 334 -- work them out.  True enough, but its not that easy!
 335 tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs)
 336   = tcVar con_name              `thenTc` \ con_id ->
 337     let
 338         con                     = case isDataConWrapId_maybe con_id of
 339                                         Just con -> con
 340                                         Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 341
 342         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 343
 344         (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 345         ex_tyvars'              = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 346         ex_tys'                 = mkTyVarTys ex_tyvars'
 347         arg_tys                 = dataConArgTys con (inst_tys ++ ex_tys')
 348         id_names                = drop (length ex_tyvars) names
 349         arg_ids
 350 #ifdef DEBUG
 351                 | length id_names /= length arg_tys
 352                 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
 353                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 354                                          ppr arg_tys)
 355                 | otherwise
 356 #endif
 357                 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
 358     in
 359     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 360     tcExtendTyVarEnv ex_tyvars'                 $
 361     tcExtendGlobalValEnv arg_ids                $
 362     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 363     returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 364 \end{code}
 365
 366 \begin{code}
 367 ifaceSigCtxt sig_name
 368   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 369 \end{code}
 370