ghc/compiler/typecheck/TcIfaceSig.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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, tcSetGlobalValEnv,
  15                           tcLookupTyConByKey, tcLookupGlobalValueMaybe,
  16                           tcExplicitLookupGlobal, badCon, badPrimOp,
  17                           GlobalValueEnv
  18                         )
  19 import TcType           ( TcKind, kindToTcKind )
  20
  21 import RnHsSyn          ( RenamedHsDecl )
  22 import HsCore
  23 import HsDecls          ( HsIdInfo(..), HsStrictnessInfo(..) )
  24 import CallConv         ( cCallConv )
  25 import Const            ( Con(..), Literal(..) )
  26 import CoreSyn
  27 import CoreUtils        ( coreExprType )
  28 import CoreUnfold
  29 import WwLib            ( mkWrapper )
  30 import PrimOp           ( PrimOp(..) )
  31
  32 import Id               ( Id, mkImportedId, mkUserId,
  33                           isPrimitiveId_maybe, isDataConId_maybe
  34                         )
  35 import IdInfo
  36 import DataCon          ( dataConSig, dataConArgTys )
  37 import SpecEnv          ( addToSpecEnv )
  38 import Type             ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
  39 import Var              ( mkTyVar, tyVarKind )
  40 import VarEnv
  41 import Name             ( Name, NamedThing(..) )
  42 import Unique           ( rationalTyConKey )
  43 import TysWiredIn       ( integerTy, stringTy )
  44 import ErrUtils         ( pprBagOfErrors )
  45 import Maybes           ( maybeToBool, MaybeErr(..) )
  46 import Outputable
  47 import Util             ( zipWithEqual )
  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 :: GlobalValueEnv       -- Envt to use when checking unfoldings
  59                 -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
  60                 -> TcM s [Id]
  61
  62
  63 tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
  64   = tcAddSrcLoc src_loc (
  65     tcAddErrCtxt (ifaceSigCtxt name) (
  66         tcHsType ty                                             `thenTc` \ sigma_ty ->
  67         tcIdInfo unf_env name sigma_ty noIdInfo id_infos        `thenTc` \ id_info ->
  68         returnTc (mkImportedId name sigma_ty id_info)
  69     ))                                          `thenTc` \ sig_id ->
  70     tcInterfaceSigs unf_env rest                `thenTc` \ sig_ids ->
  71     returnTc (sig_id : sig_ids)
  72
  73 tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
  74
  75 tcInterfaceSigs unf_env [] = returnTc []
  76 \end{code}
  77
  78 \begin{code}
  79 tcIdInfo unf_env name ty info info_ins
  80   = foldlTc tcPrag noIdInfo info_ins
  81   where
  82     tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
  83     tcPrag info (HsUpdate upd)  = returnTc (upd   `setUpdateInfo` info)
  84     tcPrag info (HsNoCafRefs)   = returnTc (NoCafRefs `setCafInfo` info)
  85
  86     tcPrag info (HsUnfold inline_prag maybe_expr)
  87         = (case maybe_expr of
  88                 Just expr -> tcPragExpr unf_env name expr
  89                 Nothing   -> returnNF_Tc Nothing
  90           )                                     `thenNF_Tc` \ maybe_expr' ->
  91           let
  92                 -- maybe_expr doesn't get looked at if the unfolding
  93                 -- is never inspected; so the typecheck doesn't even happen
  94                 unfold_info = case maybe_expr' of
  95                                 Nothing    -> NoUnfolding
  96                                 Just expr' -> mkUnfolding expr'
  97                 info1 = unfold_info `setUnfoldingInfo` info
  98
  99                 info2 = inline_prag `setInlinePragInfo` info1
 100           in
 101           returnTc info2
 102
 103     tcPrag info (HsStrictness strict)
 104         = tcStrictness unf_env ty info strict
 105
 106     tcPrag info (HsSpecialise tyvars tys rhs)
 107         = tcTyVarScope tyvars                   $ \ tyvars' ->
 108           mapAndUnzipTc tcHsTypeKind tys        `thenTc` \ (kinds, tys') ->
 109                 -- Assume that the kinds match the kinds of the
 110                 -- type variables of the function; this is, after all, an
 111                 -- interface file generated by the compiler!
 112
 113           tcPragExpr unf_env name rhs   `thenNF_Tc` \ maybe_rhs' ->
 114           let
 115                 -- If spec_env isn't looked at, none of this
 116                 -- actually takes place
 117             spec_env  = specInfo info
 118             spec_env' = case maybe_rhs' of
 119                           Nothing -> spec_env
 120                           Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
 121                                           Succeeded spec_env' -> spec_env'
 122                                           Failed err          -> pprTrace "tcIdInfo: bad specialisation"
 123                                                                           (ppr name <+> ppr err) $
 124                                                                  spec_env
 125           in
 126           returnTc (spec_env' `setSpecInfo` info)
 127 \end{code}
 128
 129 \begin{code}
 130 tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
 131   = tcWorker unf_env maybe_worker               `thenNF_Tc` \ maybe_worker_id ->
 132     uniqSMToTcM (mkWrapper ty demands)          `thenNF_Tc` \ wrap_fn ->
 133     let
 134         -- Watch out! We can't pull on maybe_worker_id too eagerly!
 135         info' = case maybe_worker_id of
 136                         Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
 137                                           setInlinePragInfo IWantToBeINLINEd info
 138
 139                         Nothing        -> info
 140
 141         has_worker = maybeToBool maybe_worker_id
 142     in
 143     returnTc (StrictnessInfo demands has_worker  `setStrictnessInfo` info')
 144
 145 -- Boring to write these out, but the result type differs from the arg type...
 146 tcStrictness unf_env ty info HsBottom
 147   = returnTc (BottomGuaranteed `setStrictnessInfo` info)
 148 \end{code}
 149
 150 \begin{code}
 151 tcWorker unf_env Nothing = returnNF_Tc Nothing
 152
 153 tcWorker unf_env (Just (worker_name,_))
 154   = returnNF_Tc (trace_maybe maybe_worker_id)
 155   where
 156     maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
 157
 158         -- The trace is so we can see what's getting dropped
 159     trace_maybe Nothing  = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
 160     trace_maybe (Just x) = Just x
 161 \end{code}
 162
 163 For unfoldings we try to do the job lazily, so that we never type check
 164 an unfolding that isn't going to be looked at.
 165
 166 \begin{code}
 167 tcPragExpr :: GlobalValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
 168 tcPragExpr unf_env name core_expr
 169   = forkNF_Tc (
 170         recoverNF_Tc no_unfolding (
 171                 tcSetGlobalValEnv unf_env $
 172                 tcCoreExpr core_expr    `thenTc` \ core_expr' ->
 173                 returnTc (Just core_expr')
 174     ))
 175   where
 176         -- The trace tells what wasn't available, for the benefit of
 177         -- compiler hackers who want to improve it!
 178     no_unfolding = getErrsTc            `thenNF_Tc` \ (warns,errs) ->
 179                    returnNF_Tc (pprTrace "tcUnfolding failed with:"
 180                                          (hang (ppr name) 4 (pprBagOfErrors errs))
 181                                          Nothing)
 182 \end{code}
 183
 184
 185 Variables in unfoldings
 186 ~~~~~~~~~~~~~~~~~~~~~~~
 187 ****** Inside here we use only the Global environment, even for locally bound variables.
 188 ****** Why? Because we know all the types and want to bind them to real Ids.
 189
 190 \begin{code}
 191 tcVar :: Name -> TcM s Id
 192 tcVar name
 193   = tcLookupGlobalValueMaybe name       `thenNF_Tc` \ maybe_id ->
 194     case maybe_id of {
 195         Just id -> returnTc id;
 196         Nothing -> failWithTc (noDecl name)
 197     }
 198
 199 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 200 \end{code}
 201
 202 UfCore expressions.
 203
 204 \begin{code}
 205 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
 206
 207 tcCoreExpr (UfType ty)
 208   = tcHsTypeKind ty     `thenTc` \ (_, ty') ->
 209         -- It might not be of kind type
 210     returnTc (Type ty')
 211
 212 tcCoreExpr (UfVar name)
 213   = tcVar name  `thenTc` \ id ->
 214     returnTc (Var id)
 215
 216 tcCoreExpr (UfCon con args)
 217   = tcUfCon con                 `thenTc` \ con' ->
 218     mapTc tcCoreExpr args       `thenTc` \ args' ->
 219     returnTc (Con con' args')
 220
 221 tcCoreExpr (UfTuple name args)
 222   = tcUfDataCon name            `thenTc` \ con ->
 223     mapTc tcCoreExpr args       `thenTc` \ args' ->
 224     let
 225         -- Put the missing type arguments back in
 226         con_args = map (Type . coreExprType) args' ++ args'
 227     in
 228     returnTc (Con con con_args)
 229
 230 tcCoreExpr (UfLam bndr body)
 231   = tcCoreLamBndr bndr          $ \ bndr' ->
 232     tcCoreExpr body             `thenTc` \ body' ->
 233     returnTc (Lam bndr' body')
 234
 235 tcCoreExpr (UfApp fun arg)
 236   = tcCoreExpr fun              `thenTc` \ fun' ->
 237     tcCoreExpr arg              `thenTc` \ arg' ->
 238     returnTc (App fun' arg')
 239
 240 tcCoreExpr (UfCase scrut case_bndr alts)
 241   = tcCoreExpr scrut                                    `thenTc` \ scrut' ->
 242     let
 243         scrut_ty = coreExprType scrut'
 244         case_bndr' = mkUserId case_bndr scrut_ty
 245     in
 246     tcExtendGlobalValEnv [case_bndr']   $
 247     mapTc (tcCoreAlt scrut_ty) alts     `thenTc` \ alts' ->
 248     returnTc (Case scrut' case_bndr' alts')
 249
 250 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 251   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 252     tcCoreValBndr bndr          $ \ bndr' ->
 253     tcCoreExpr body             `thenTc` \ body' ->
 254     returnTc (Let (NonRec bndr' rhs') body')
 255
 256 tcCoreExpr (UfLet (UfRec pairs) body)
 257   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 258     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 259     tcCoreExpr body             `thenTc` \ body' ->
 260     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 261   where
 262     (bndrs, rhss) = unzip pairs
 263
 264 tcCoreExpr (UfNote note expr)
 265   = tcCoreExpr expr             `thenTc` \ expr' ->
 266     case note of
 267         UfCoerce to_ty -> tcHsTypeKind to_ty    `thenTc` \ (_,to_ty') ->
 268                           returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
 269         UfInlineCall   -> returnTc (Note InlineCall expr')
 270         UfSCC cc       -> returnTc (Note (SCC cc) expr')
 271
 272 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 273 tcCoreNote UfInlineCall = returnTc InlineCall
 274
 275
 276 -- rationalTy isn't built in so, we have to construct it
 277 -- (the "ty" part of the incoming literal is simply bottom)
 278 tcUfCon (UfLitCon (NoRepRational lit _))
 279   = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 280     let
 281         rational_ty  = mkSynTy rational_tycon []
 282     in
 283     returnTc (Literal (NoRepRational lit rational_ty))
 284
 285 -- Similarly for integers and strings, except that they are wired in
 286 tcUfCon (UfLitCon (NoRepInteger lit _))
 287   = returnTc (Literal (NoRepInteger lit integerTy))
 288 tcUfCon (UfLitCon (NoRepStr lit _))
 289   = returnTc (Literal (NoRepStr lit stringTy))
 290
 291 tcUfCon (UfLitCon other_lit)
 292   = returnTc (Literal other_lit)
 293
 294 -- The dreaded lit-lits are also similar, except here the type
 295 -- is read in explicitly rather than being implicit
 296 tcUfCon (UfLitLitCon lit ty)
 297   = tcHsType ty         `thenTc` \ ty' ->
 298     returnTc (Literal (MachLitLit lit ty'))
 299
 300 tcUfCon (UfDataCon name) = tcUfDataCon name
 301
 302 tcUfCon (UfPrimOp name)
 303   = tcVar name          `thenTc` \ op_id ->
 304     case isPrimitiveId_maybe op_id of
 305         Just op -> returnTc (PrimOp op)
 306         Nothing -> failWithTc (badPrimOp name)
 307
 308 tcUfCon (UfCCallOp str casm gc)
 309   = returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
 310
 311 tcUfDataCon name
 312   = tcVar name          `thenTc` \ con_id ->
 313     case isDataConId_maybe con_id of
 314         Just con -> returnTc (DataCon con)
 315         Nothing  -> failWithTc (badCon name)
 316 \end{code}
 317
 318 \begin{code}
 319 tcCoreLamBndr (UfValBinder name ty) thing_inside
 320   = tcHsType ty                 `thenTc` \ ty' ->
 321     let
 322         id = mkUserId name ty'
 323     in
 324     tcExtendGlobalValEnv [id] $
 325     thing_inside id
 326
 327 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 328   = let
 329         tyvar = mkTyVar name kind
 330     in
 331     tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
 332     thing_inside tyvar
 333
 334 tcCoreValBndr (UfValBinder name ty) thing_inside
 335   = tcHsType ty                 `thenTc` \ ty' ->
 336     let
 337         id = mkUserId name ty'
 338     in
 339     tcExtendGlobalValEnv [id] $
 340     thing_inside id
 341
 342 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 343   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 344     let
 345         ids = zipWithEqual "tcCoreValBndr" mkUserId names tys'
 346     in
 347     tcExtendGlobalValEnv ids $
 348     thing_inside ids
 349   where
 350     names = [name | UfValBinder name _  <- bndrs]
 351     tys   = [ty   | UfValBinder _    ty <- bndrs]
 352 \end{code}
 353
 354 \begin{code}
 355 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 356   = ASSERT( null names )
 357     tcCoreExpr rhs              `thenTc` \ rhs' ->
 358     returnTc (DEFAULT, [], rhs')
 359
 360 tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
 361   = ASSERT( null names )
 362     tcCoreExpr rhs              `thenTc` \ rhs' ->
 363     returnTc (Literal lit, [], rhs')
 364
 365 tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
 366   = ASSERT( null names )
 367     tcCoreExpr rhs              `thenTc` \ rhs' ->
 368     tcHsType ty                 `thenTc` \ ty' ->
 369     returnTc (Literal (MachLitLit str ty'), [], rhs')
 370
 371 -- A case alternative is made quite a bit more complicated
 372 -- by the fact that we omit type annotations because we can
 373 -- work them out.  True enough, but its not that easy!
 374 tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
 375   = tcVar con_name              `thenTc` \ con_id ->
 376     let
 377         con                     = case isDataConId_maybe con_id of
 378                                         Just con -> con
 379                                         Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 380
 381         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 382
 383         (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
 384         ex_tyvars'              = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 385         ex_tys'                 = mkTyVarTys ex_tyvars'
 386         arg_tys                 = dataConArgTys con (inst_tys ++ ex_tys')
 387         id_names                = drop (length ex_tyvars) names
 388         arg_ids
 389 #ifdef DEBUG
 390                 | length id_names /= length arg_tys
 391                 = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
 392                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 393                                          ppr arg_tys)
 394                 | otherwise
 395 #endif
 396                 = zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys
 397     in
 398     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 399     tcExtendTyVarEnv (map getName ex_tyvars')
 400                      [ (kindToTcKind (tyVarKind tv), tv)
 401                      | tv <- ex_tyvars']                $
 402     tcExtendGlobalValEnv arg_ids                        $
 403     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 404     returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
 405 \end{code}
 406
 407 \begin{code}
 408 ifaceSigCtxt sig_name
 409   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 410 \end{code}
 411