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                           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   = mapTc tcCoreExpr args       `thenTc` \ args' ->
 205     tcUfCon con args'
 206
 207 tcCoreExpr (UfTuple name args)
 208   =     -- See notes with tcUfCon (UfDataCon ...)
 209     tcVar name                  `thenTc` \ con_id ->
 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 (mkApps (Var con_id) 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 ----------------------------------
 266 tcUfCon (UfLitCon lit) args
 267   = ASSERT( null args)
 268     tcUfLit lit         `thenTc` \ lit ->
 269     returnTc (Con (Literal lit) [])
 270
 271 -- The dreaded lit-lits are also similar, except here the type
 272 -- is read in explicitly rather than being implicit
 273 tcUfCon (UfLitLitCon lit ty) args
 274   = ASSERT( null args )
 275     tcHsType ty         `thenTc` \ ty' ->
 276     returnTc (Con (Literal (MachLitLit lit ty')) [])
 277
 278 -- Primops are reverse-engineered
 279 -- into applications of their Ids.  In this way, any
 280 -- RULES that apply to the Id will work when this thing is unfolded.
 281 -- It's a bit of a hack, but it works nicely
 282 -- Can't do it for datacons, because the data con Id doesn't necessarily
 283 -- have the same type as the data con (existentials)
 284
 285 tcUfCon (UfPrimOp name)  args = tcVar name              `thenTc` \ op_id ->
 286                                 returnTc (mkApps (Var op_id) args)
 287
 288 tcUfCon (UfDataCon name) args
 289   = tcVar name          `thenTc` \ con_id ->
 290     case isDataConId_maybe con_id of
 291         Just con -> returnTc (mkConApp con args)
 292         Nothing  -> failWithTc (badCon name)
 293
 294 tcUfCon (UfCCallOp str is_dyn casm gc) args
 295   | is_dyn    = tcGetUnique `thenNF_Tc` \ u ->
 296                 returnTc (Con (PrimOp (CCallOp (Right u) casm gc cCallConv)) args)
 297   | otherwise = returnTc (Con (PrimOp (CCallOp (Left str) casm gc cCallConv)) args)
 298
 299 ----------------------------------
 300 tcUfLit (NoRepRational lit _)
 301   =     -- rationalTy isn't built in so, we have to construct it
 302         -- (the "ty" part of the incoming literal is simply bottom)
 303     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 304     let
 305         rational_ty  = mkSynTy rational_tycon []
 306     in
 307     returnTc (NoRepRational lit rational_ty)
 308
 309 -- Similarly for integers and strings, except that they are wired in
 310 tcUfLit (NoRepInteger lit _) = returnTc (NoRepInteger lit integerTy)
 311 tcUfLit (NoRepStr lit _)     = returnTc (NoRepStr lit stringTy)
 312 tcUfLit other_lit            = returnTc other_lit
 313 \end{code}
 314
 315 \begin{code}
 316 tcCoreLamBndr (UfValBinder name ty) thing_inside
 317   = tcHsType ty                 `thenTc` \ ty' ->
 318     let
 319         id = mkVanillaId name ty'
 320     in
 321     tcExtendGlobalValEnv [id] $
 322     thing_inside id
 323
 324 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 325   = let
 326         tyvar = mkTyVar name kind
 327     in
 328     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 329
 330 tcCoreLamBndrs []     thing_inside = thing_inside []
 331 tcCoreLamBndrs (b:bs) thing_inside
 332   = tcCoreLamBndr b     $ \ b' ->
 333     tcCoreLamBndrs bs   $ \ bs' ->
 334     thing_inside (b':bs')
 335
 336 tcCoreValBndr (UfValBinder name ty) thing_inside
 337   = tcHsType ty                 `thenTc` \ ty' ->
 338     let
 339         id = mkVanillaId name ty'
 340     in
 341     tcExtendGlobalValEnv [id] $
 342     thing_inside id
 343
 344 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 345   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 346     let
 347         ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
 348     in
 349     tcExtendGlobalValEnv ids $
 350     thing_inside ids
 351   where
 352     names = [name | UfValBinder name _  <- bndrs]
 353     tys   = [ty   | UfValBinder _    ty <- bndrs]
 354 \end{code}
 355
 356 \begin{code}
 357 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 358   = ASSERT( null names )
 359     tcCoreExpr rhs              `thenTc` \ rhs' ->
 360     returnTc (DEFAULT, [], rhs')
 361
 362 tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
 363   = ASSERT( null names )
 364     tcCoreExpr rhs              `thenTc` \ rhs' ->
 365     returnTc (Literal lit, [], rhs')
 366
 367 tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
 368   = ASSERT( null names )
 369     tcCoreExpr rhs              `thenTc` \ rhs' ->
 370     tcHsType ty                 `thenTc` \ ty' ->
 371     returnTc (Literal (MachLitLit str ty'), [], rhs')
 372
 373 -- A case alternative is made quite a bit more complicated
 374 -- by the fact that we omit type annotations because we can
 375 -- work them out.  True enough, but its not that easy!
 376 tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
 377   = tcVar con_name              `thenTc` \ con_id ->
 378     let
 379         con                     = case isDataConId_maybe con_id of
 380                                         Just con -> con
 381                                         Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 382
 383         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 384
 385         (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 386         ex_tyvars'              = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 387         ex_tys'                 = mkTyVarTys ex_tyvars'
 388         arg_tys                 = dataConArgTys con (inst_tys ++ ex_tys')
 389         id_names                = drop (length ex_tyvars) names
 390         arg_ids
 391 #ifdef DEBUG
 392                 | length id_names /= length arg_tys
 393                 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
 394                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 395                                          ppr arg_tys)
 396                 | otherwise
 397 #endif
 398                 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
 399     in
 400     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 401     tcExtendTyVarEnv ex_tyvars'                 $
 402     tcExtendGlobalValEnv arg_ids                $
 403     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 404     returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
 405 \end{code}
 406
 407 \begin{code}
 408 ifaceSigCtxt sig_name
 409   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 410 \end{code}
 411