ghc/compiler/typecheck/TcIfaceSig.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
   5
   6 \begin{code}
   7 module TcIfaceSig ( tcInterfaceSigs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), IfaceSig(..) )
  12 import TcMonad
  13 import TcMonoType       ( tcHsType, tcHsTypeKind )
  14 import TcEnv            ( tcExtendTyVarEnv, tcExtendGlobalValEnv,
  15                           tcLookupTyConByKey, tcLookupGlobalValueMaybe,
  16                           tcExplicitLookupGlobal
  17                         )
  18 import TcKind           ( TcKind, kindToTcKind )
  19
  20 import RnHsSyn          ( RenamedHsDecl(..) )
  21 import HsCore
  22 import HsDecls          ( HsIdInfo(..), HsStrictnessInfo(..) )
  23 import Literal          ( Literal(..) )
  24 import CoreSyn
  25 import CoreUtils        ( coreExprType )
  26 import CoreUnfold
  27 import MagicUFs         ( MagicUnfoldingFun )
  28 import WwLib            ( mkWrapper )
  29 import PrimOp           ( PrimOp(..) )
  30
  31 import Id               ( GenId, mkImported, mkUserId, addInlinePragma,
  32                           isPrimitiveId_maybe, dataConArgTys, Id )
  33 import Type             ( mkSynTy, splitAlgTyConApp )
  34 import TyVar            ( mkSysTyVar )
  35 import Name             ( Name )
  36 import Unique           ( rationalTyConKey, uniqueOf )
  37 import TysWiredIn       ( integerTy )
  38 import PragmaInfo       ( PragmaInfo(..) )
  39 import ErrUtils         ( pprBagOfErrors )
  40 import Maybes           ( maybeToBool )
  41 import Outputable
  42 import Util             ( zipWithEqual )
  43
  44 import IdInfo
  45 \end{code}
  46
  47 Ultimately, type signatures in interfaces will have pragmatic
  48 information attached, so it is a good idea to have separate code to
  49 check them.
  50
  51 As always, we do not have to worry about user-pragmas in interface
  52 signatures.
  53
  54 \begin{code}
  55 tcInterfaceSigs :: TcEnv s              -- Envt to use when checking unfoldings
  56                 -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
  57                 -> TcM s [Id]
  58
  59
  60 tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
  61   = tcAddSrcLoc src_loc (
  62     tcAddErrCtxt (ifaceSigCtxt name) (
  63         tcHsType ty                                             `thenTc` \ sigma_ty ->
  64         tcIdInfo unf_env name sigma_ty noIdInfo id_infos        `thenTc` \ id_info' ->
  65         let
  66             imp_id = mkImported name sigma_ty id_info'
  67             sig_id | any inline_please id_infos = addInlinePragma imp_id
  68                    | otherwise                  = imp_id
  69
  70             inline_please (HsUnfold inline _) = inline
  71             inline_please other           = False
  72         in
  73         returnTc sig_id
  74     ))                                          `thenTc` \ sig_id ->
  75     tcInterfaceSigs unf_env rest                `thenTc` \ sig_ids ->
  76     returnTc (sig_id : sig_ids)
  77
  78 tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
  79
  80 tcInterfaceSigs unf_env [] = returnTc []
  81 \end{code}
  82
  83 \begin{code}
  84 tcIdInfo unf_env name ty info info_ins
  85   = go noIdInfo info_ins
  86   where
  87     go info_so_far []              = returnTc info_so_far
  88     go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
  89     go info (HsUpdate upd : rest)  = go (info `addUpdateInfo` upd)  rest
  90     go info (HsFBType fb : rest)   = go (info `addFBTypeInfo` fb)   rest
  91     go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
  92
  93     go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr       `thenNF_Tc` \ unfold_info ->
  94                                             go (info `addUnfoldInfo` unfold_info) rest
  95
  96     go info (HsStrictness strict : rest)  = tcStrictness unf_env ty info strict `thenTc` \ info' ->
  97                                             go info' rest
  98 \end{code}
  99
 100 \begin{code}
 101 tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
 102   = tcWorker unf_env maybe_worker               `thenNF_Tc` \ maybe_worker_id ->
 103     uniqSMToTcM (mkWrapper ty demands)          `thenNF_Tc` \ wrap_fn ->
 104     let
 105         -- Watch out! We can't pull on maybe_worker_id too eagerly!
 106         info' = case maybe_worker_id of
 107                         Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
 108                         Nothing        -> info
 109         has_worker = maybeToBool maybe_worker_id
 110     in
 111     returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
 112
 113 -- Boring to write these out, but the result type differs from the arg type...
 114 tcStrictness unf_env ty info HsBottom
 115   = returnTc (info `addStrictnessInfo` BottomGuaranteed)
 116 \end{code}
 117
 118 \begin{code}
 119 tcWorker unf_env Nothing = returnNF_Tc Nothing
 120
 121 tcWorker unf_env (Just (worker_name,_))
 122   = returnNF_Tc (trace_maybe maybe_worker_id)
 123   where
 124     maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
 125
 126         -- The trace is so we can see what's getting dropped
 127     trace_maybe Nothing  = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
 128     trace_maybe (Just x) = Just x
 129 \end{code}
 130
 131 For unfoldings we try to do the job lazily, so that we never type check
 132 an unfolding that isn't going to be looked at.
 133
 134 \begin{code}
 135 tcUnfolding unf_env name core_expr
 136   = forkNF_Tc (
 137         recoverNF_Tc no_unfolding (
 138                 tcSetEnv unf_env $
 139                 tcCoreExpr core_expr    `thenTc` \ core_expr' ->
 140                 returnTc (mkUnfolding NoPragmaInfo core_expr')
 141     ))
 142   where
 143         -- The trace tells what wasn't available, for the benefit of
 144         -- compiler hackers who want to improve it!
 145     no_unfolding = getErrsTc            `thenNF_Tc` \ (warns,errs) ->
 146                    returnNF_Tc (pprTrace "tcUnfolding failed with:"
 147                                         (hang (ppr name) 4 (pprBagOfErrors errs))
 148                                         NoUnfolding)
 149 \end{code}
 150
 151
 152 Variables in unfoldings
 153 ~~~~~~~~~~~~~~~~~~~~~~~
 154 ****** Inside here we use only the Global environment, even for locally bound variables.
 155 ****** Why? Because we know all the types and want to bind them to real Ids.
 156
 157 \begin{code}
 158 tcVar :: Name -> TcM s Id
 159 tcVar name
 160   = tcLookupGlobalValueMaybe name       `thenNF_Tc` \ maybe_id ->
 161     case maybe_id of {
 162         Just id -> returnTc id;
 163         Nothing -> failWithTc (noDecl name)
 164     }
 165
 166 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 167 \end{code}
 168
 169 UfCore expressions.
 170
 171 \begin{code}
 172 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
 173
 174 tcCoreExpr (UfVar name)
 175   = tcVar name  `thenTc` \ id ->
 176     returnTc (Var id)
 177
 178 -- rationalTy isn't built in so we have to construct it
 179 -- (the "ty" part of the incoming literal is simply bottom)
 180 tcCoreExpr (UfLit (NoRepRational lit _))
 181   = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 182     let
 183         rational_ty  = mkSynTy rational_tycon []
 184     in
 185     returnTc (Lit (NoRepRational lit rational_ty))
 186
 187 -- Similarly for integers, except that it is wired in
 188 tcCoreExpr (UfLit (NoRepInteger lit _))
 189   = returnTc (Lit (NoRepInteger lit integerTy))
 190
 191 tcCoreExpr (UfLit other_lit)
 192   = returnTc (Lit other_lit)
 193
 194 tcCoreExpr (UfCon con args)
 195   = tcVar con                   `thenTc` \ con_id ->
 196     mapTc tcCoreArg args        `thenTc` \ args' ->
 197     returnTc (Con con_id args')
 198
 199 tcCoreExpr (UfPrim prim args)
 200   = tcCorePrim prim             `thenTc` \ primop ->
 201     mapTc tcCoreArg args        `thenTc` \ args' ->
 202     returnTc (Prim primop args')
 203
 204 tcCoreExpr (UfApp fun arg)
 205   = tcCoreExpr fun              `thenTc` \ fun' ->
 206     tcCoreArg arg               `thenTc` \ arg' ->
 207     returnTc (App fun' arg')
 208
 209 tcCoreExpr (UfCase scrut alts)
 210   = tcCoreExpr scrut                            `thenTc` \ scrut' ->
 211     tcCoreAlts (coreExprType scrut') alts       `thenTc` \ alts' ->
 212     returnTc (Case scrut' alts')
 213
 214 tcCoreExpr (UfSCC cc expr)
 215   = tcCoreExpr expr             `thenTc` \ expr' ->
 216     returnTc  (SCC cc expr')
 217
 218 tcCoreExpr(UfCoerce coercion ty body)
 219   = tcCoercion coercion         `thenTc` \ coercion' ->
 220     tcHsTypeKind ty             `thenTc` \ (_,ty') ->
 221     tcCoreExpr body             `thenTc` \ body' ->
 222     returnTc (Coerce coercion' ty' body')
 223
 224 tcCoreExpr (UfLam bndr body)
 225   = tcCoreLamBndr bndr          $ \ bndr' ->
 226     tcCoreExpr body             `thenTc` \ body' ->
 227     returnTc (Lam bndr' body')
 228
 229 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 230   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 231     tcCoreValBndr bndr          $ \ bndr' ->
 232     tcCoreExpr body             `thenTc` \ body' ->
 233     returnTc (Let (NonRec bndr' rhs') body')
 234
 235 tcCoreExpr (UfLet (UfRec pairs) body)
 236   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 237     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 238     tcCoreExpr body             `thenTc` \ body' ->
 239     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 240   where
 241     (bndrs, rhss) = unzip pairs
 242 \end{code}
 243
 244 \begin{code}
 245 tcCoreLamBndr (UfValBinder name ty) thing_inside
 246   = tcHsType ty                 `thenTc` \ ty' ->
 247     let
 248         id = mkUserId name ty' NoPragmaInfo
 249     in
 250     tcExtendGlobalValEnv [id] $
 251     thing_inside (ValBinder id)
 252
 253 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 254   = let
 255         tyvar = mkSysTyVar (uniqueOf name) kind
 256     in
 257     tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
 258     thing_inside (TyBinder tyvar)
 259
 260 tcCoreValBndr (UfValBinder name ty) thing_inside
 261   = tcHsType ty                 `thenTc` \ ty' ->
 262     let
 263         id = mk_id name ty'
 264     in
 265     tcExtendGlobalValEnv [id] $
 266     thing_inside id
 267
 268 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 269   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 270     let
 271         ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
 272     in
 273     tcExtendGlobalValEnv ids $
 274     thing_inside ids
 275   where
 276     names = map (\ (UfValBinder name _) -> name) bndrs
 277     tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
 278
 279 mk_id name ty = mkUserId name ty NoPragmaInfo
 280 \end{code}
 281
 282 \begin{code}
 283 tcCoreArg (UfVarArg v)   = tcVar v              `thenTc` \ v' -> returnTc (VarArg v')
 284 tcCoreArg (UfTyArg ty)   = tcHsTypeKind ty      `thenTc` \ (_,ty') -> returnTc (TyArg ty')
 285 tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
 286
 287 tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
 288   = mapTc tc_alt alts                   `thenTc` \ alts' ->
 289     tcCoreDefault scrut_ty deflt        `thenTc` \ deflt' ->
 290     returnTc (AlgAlts alts' deflt')
 291   where
 292     tc_alt (con, names, rhs)
 293       = tcVar con                       `thenTc` \ con' ->
 294         let
 295             arg_tys                 = dataConArgTys con' inst_tys
 296             (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 297             arg_ids                 = zipWithEqual "tcCoreAlts" mk_id names arg_tys
 298         in
 299         tcExtendGlobalValEnv arg_ids    $
 300         tcCoreExpr rhs                  `thenTc` \ rhs' ->
 301         returnTc (con', arg_ids, rhs')
 302
 303 tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
 304   = mapTc tc_alt alts                   `thenTc` \ alts' ->
 305     tcCoreDefault scrut_ty deflt        `thenTc` \ deflt' ->
 306     returnTc (PrimAlts alts' deflt')
 307   where
 308     tc_alt (lit, rhs) = tcCoreExpr rhs          `thenTc` \ rhs' ->
 309                         returnTc (lit, rhs')
 310
 311 tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
 312 tcCoreDefault scrut_ty (UfBindDefault name rhs)
 313   = let
 314         deflt_id           = mk_id name scrut_ty
 315     in
 316     tcExtendGlobalValEnv [deflt_id]     $
 317     tcCoreExpr rhs                      `thenTc` \ rhs' ->
 318     returnTc (BindDefault deflt_id rhs')
 319
 320
 321 tcCoercion (UfIn  n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn  n')
 322 tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n')
 323
 324 tcCorePrim (UfOtherOp op)
 325   = tcVar op            `thenTc` \ op_id ->
 326     case isPrimitiveId_maybe op_id of
 327         Just prim_op -> returnTc prim_op
 328         Nothing      -> pprPanic "tcCorePrim" (ppr op_id)
 329
 330 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
 331   = mapTc tcHsType arg_tys      `thenTc` \ arg_tys' ->
 332     tcHsType res_ty             `thenTc` \ res_ty' ->
 333     returnTc (CCallOp str casm gc arg_tys' res_ty')
 334 \end{code}
 335
 336 \begin{code}
 337 ifaceSigCtxt sig_name
 338   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 339 \end{code}
 340