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