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