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