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