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