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