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