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, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( TyClDecl(..), HsTupCon(..) )
  12 import TcMonad
  13 import TcMonoType       ( tcIfaceType )
  14 import TcEnv            ( TcEnv, RecTcEnv, tcExtendTyVarEnv,
  15                           tcExtendGlobalValEnv, tcSetEnv,
  16                           tcLookupGlobal_maybe, tcLookupRecId_maybe
  17                         )
  18
  19 import RnHsSyn          ( RenamedTyClDecl )
  20 import HsCore
  21 import Literal          ( Literal(..) )
  22 import CoreSyn
  23 import CoreUtils        ( exprType )
  24 import CoreUnfold
  25 import CoreLint         ( lintUnfolding )
  26 import WorkWrap         ( mkWrapper )
  27
  28 import Id               ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
  29 import MkId             ( mkCCallOpId )
  30 import IdInfo
  31 import DataCon          ( DataCon, dataConId, dataConSig, dataConArgTys )
  32 import Type             ( mkTyVarTys, splitAlgTyConApp_maybe )
  33 import TysWiredIn       ( tupleCon )
  34 import Var              ( mkTyVar, tyVarKind )
  35 import Name             ( Name )
  36 import Demand           ( wwLazy )
  37 import ErrUtils         ( pprBagOfErrors )
  38 import Outputable
  39 import Util             ( zipWithEqual )
  40 import HscTypes         ( TyThing(..) )
  41 \end{code}
  42
  43 Ultimately, type signatures in interfaces will have pragmatic
  44 information attached, so it is a good idea to have separate code to
  45 check them.
  46
  47 As always, we do not have to worry about user-pragmas in interface
  48 signatures.
  49
  50 \begin{code}
  51 tcInterfaceSigs :: RecTcEnv             -- Envt to use when checking unfoldings
  52                 -> [RenamedTyClDecl]    -- Ignore non-sig-decls in these decls
  53                 -> TcM [Id]
  54
  55
  56 tcInterfaceSigs unf_env decls
  57   = listTc [ do_one name ty id_infos src_loc
  58            | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
  59   where
  60     in_scope_vars = []  -- I think this will be OK
  61
  62     do_one name ty id_infos src_loc
  63       = tcAddSrcLoc src_loc                             $
  64         tcAddErrCtxt (ifaceSigCtxt name)                $
  65         tcIfaceType ty                                  `thenTc` \ sigma_ty ->
  66         tcIdInfo unf_env in_scope_vars name
  67                  sigma_ty id_infos                      `thenTc` \ id_info ->
  68         returnTc (mkId name sigma_ty id_info)
  69 \end{code}
  70
  71 \begin{code}
  72 tcIdInfo unf_env in_scope_vars name ty info_ins
  73   = foldlTc tcPrag constantIdInfo info_ins
  74   where
  75     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
  76     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`    NoCafRefs)
  77     tcPrag info HsCprInfo       = returnTc (info `setCprInfo`    ReturnsCPR)
  78
  79     tcPrag info (HsUnfold inline_prag expr)
  80         = tcPragExpr unf_env name in_scope_vars expr    `thenNF_Tc` \ maybe_expr' ->
  81           let
  82                 -- maybe_expr doesn't get looked at if the unfolding
  83                 -- is never inspected; so the typecheck doesn't even happen
  84                 unfold_info = case maybe_expr' of
  85                                 Nothing    -> noUnfolding
  86                                 Just expr' -> mkTopUnfolding expr'
  87                 info1 = info `setUnfoldingInfo` unfold_info
  88                 info2 = info1 `setInlinePragInfo` inline_prag
  89           in
  90           returnTc info2
  91
  92     tcPrag info (HsStrictness strict_info)
  93         = returnTc (info `setStrictnessInfo` strict_info)
  94
  95     tcPrag info (HsWorker nm)
  96         = tcWorkerInfo unf_env ty info nm
  97 \end{code}
  98
  99 \begin{code}
 100 tcWorkerInfo unf_env ty info worker_name
 101   | not (hasArity arity_info)
 102   = pprPanic "Worker with no arity info" (ppr worker_name)
 103
 104   | otherwise
 105   = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
 106     let
 107         -- Watch out! We can't pull on unf_env too eagerly!
 108         info' = case tcLookupRecId_maybe unf_env worker_name of
 109                   Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
 110                                          `setWorkerInfo`     HasWorker worker_id arity
 111
 112                   Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
 113     in
 114     returnTc info'
 115   where
 116         -- We are relying here on arity, cpr and strictness info always appearing
 117         -- before worker info,  fingers crossed ....
 118       arity_info = arityInfo info
 119       arity      = arityLowerBound arity_info
 120       cpr_info   = cprInfo info
 121       (demands, res_bot)    = case strictnessInfo info of
 122                                 StrictnessInfo d r -> (d,r)
 123                                 _                  -> (take arity (repeat wwLazy),False)        -- Noncommittal
 124 \end{code}
 125
 126 For unfoldings we try to do the job lazily, so that we never type check
 127 an unfolding that isn't going to be looked at.
 128
 129 \begin{code}
 130 tcPragExpr unf_env name in_scope_vars expr
 131   = tcDelay unf_env doc $
 132         tcCoreExpr expr         `thenTc` \ core_expr' ->
 133
 134                 -- Check for type consistency in the unfolding
 135         tcGetSrcLoc             `thenNF_Tc` \ src_loc ->
 136         getDOptsTc              `thenTc` \ dflags ->
 137         case lintUnfolding dflags src_loc in_scope_vars core_expr' of
 138           (Nothing,_)       -> returnTc core_expr'  -- ignore warnings
 139           (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
 140   where
 141     doc = text "unfolding of" <+> ppr name
 142
 143 tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
 144 tcDelay unf_env doc thing_inside
 145   = forkNF_Tc (
 146         recoverNF_Tc bad_value (
 147                 tcSetEnv unf_env thing_inside   `thenTc` \ r ->
 148                 returnTc (Just r)
 149     ))
 150   where
 151         -- The trace tells what wasn't available, for the benefit of
 152         -- compiler hackers who want to improve it!
 153     bad_value = getErrsTc               `thenNF_Tc` \ (warns,errs) ->
 154                 returnNF_Tc (pprTrace "Failed:"
 155                                          (hang doc 4 (pprBagOfErrors errs))
 156                                          Nothing)
 157 \end{code}
 158
 159
 160 Variables in unfoldings
 161 ~~~~~~~~~~~~~~~~~~~~~~~
 162 ****** Inside here we use only the Global environment, even for locally bound variables.
 163 ****** Why? Because we know all the types and want to bind them to real Ids.
 164
 165 \begin{code}
 166 tcVar :: Name -> TcM Id
 167 tcVar name
 168   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
 169     case maybe_id of {
 170         Just (AnId id)  -> returnTc id;
 171         Nothing         -> failWithTc (noDecl name)
 172     }
 173
 174 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 175 \end{code}
 176
 177 UfCore expressions.
 178
 179 \begin{code}
 180 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 181
 182 tcCoreExpr (UfType ty)
 183   = tcIfaceType ty              `thenTc` \ ty' ->
 184         -- It might not be of kind type
 185     returnTc (Type ty')
 186
 187 tcCoreExpr (UfVar name)
 188   = tcVar name  `thenTc` \ id ->
 189     returnTc (Var id)
 190
 191 tcCoreExpr (UfLit lit)
 192   = returnTc (Lit lit)
 193
 194 -- The dreaded lit-lits are also similar, except here the type
 195 -- is read in explicitly rather than being implicit
 196 tcCoreExpr (UfLitLit lit ty)
 197   = tcIfaceType ty              `thenTc` \ ty' ->
 198     returnTc (Lit (MachLitLit lit ty'))
 199
 200 tcCoreExpr (UfCCall cc ty)
 201   = tcIfaceType ty      `thenTc` \ ty' ->
 202     tcGetUnique         `thenNF_Tc` \ u ->
 203     returnTc (Var (mkCCallOpId u cc ty'))
 204
 205 tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
 206   = mapTc tcCoreExpr args       `thenTc` \ args' ->
 207     let
 208         -- Put the missing type arguments back in
 209         con_args = map (Type . exprType) args' ++ args'
 210     in
 211     returnTc (mkApps (Var con_id) con_args)
 212   where
 213     con_id = dataConId (tupleCon boxity arity)
 214
 215
 216 tcCoreExpr (UfLam bndr body)
 217   = tcCoreLamBndr bndr          $ \ bndr' ->
 218     tcCoreExpr body             `thenTc` \ body' ->
 219     returnTc (Lam bndr' body')
 220
 221 tcCoreExpr (UfApp fun arg)
 222   = tcCoreExpr fun              `thenTc` \ fun' ->
 223     tcCoreExpr arg              `thenTc` \ arg' ->
 224     returnTc (App fun' arg')
 225
 226 tcCoreExpr (UfCase scrut case_bndr alts)
 227   = tcCoreExpr scrut                                    `thenTc` \ scrut' ->
 228     let
 229         scrut_ty = exprType scrut'
 230         case_bndr' = mkVanillaId case_bndr scrut_ty
 231     in
 232     tcExtendGlobalValEnv [case_bndr']   $
 233     mapTc (tcCoreAlt scrut_ty) alts     `thenTc` \ alts' ->
 234     returnTc (Case scrut' case_bndr' alts')
 235
 236 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 237   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 238     tcCoreValBndr bndr          $ \ bndr' ->
 239     tcCoreExpr body             `thenTc` \ body' ->
 240     returnTc (Let (NonRec bndr' rhs') body')
 241
 242 tcCoreExpr (UfLet (UfRec pairs) body)
 243   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 244     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 245     tcCoreExpr body             `thenTc` \ body' ->
 246     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 247   where
 248     (bndrs, rhss) = unzip pairs
 249
 250 tcCoreExpr (UfNote note expr)
 251   = tcCoreExpr expr             `thenTc` \ expr' ->
 252     case note of
 253         UfCoerce to_ty -> tcIfaceType to_ty     `thenTc` \ to_ty' ->
 254                           returnTc (Note (Coerce to_ty'
 255                                                  (exprType expr')) expr')
 256         UfInlineCall   -> returnTc (Note InlineCall expr')
 257         UfInlineMe     -> returnTc (Note InlineMe   expr')
 258         UfSCC cc       -> returnTc (Note (SCC cc)   expr')
 259 \end{code}
 260
 261 \begin{code}
 262 tcCoreLamBndr (UfValBinder name ty) thing_inside
 263   = tcIfaceType ty              `thenTc` \ ty' ->
 264     let
 265         id = mkVanillaId name ty'
 266     in
 267     tcExtendGlobalValEnv [id] $
 268     thing_inside id
 269
 270 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 271   = let
 272         tyvar = mkTyVar name kind
 273     in
 274     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 275
 276 tcCoreLamBndrs []     thing_inside = thing_inside []
 277 tcCoreLamBndrs (b:bs) thing_inside
 278   = tcCoreLamBndr b     $ \ b' ->
 279     tcCoreLamBndrs bs   $ \ bs' ->
 280     thing_inside (b':bs')
 281
 282 tcCoreValBndr (UfValBinder name ty) thing_inside
 283   = tcIfaceType ty                      `thenTc` \ ty' ->
 284     let
 285         id = mkVanillaId name ty'
 286     in
 287     tcExtendGlobalValEnv [id] $
 288     thing_inside id
 289
 290 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 291   = mapTc tcIfaceType tys               `thenTc` \ tys' ->
 292     let
 293         ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
 294     in
 295     tcExtendGlobalValEnv ids $
 296     thing_inside ids
 297   where
 298     names = [name | UfValBinder name _  <- bndrs]
 299     tys   = [ty   | UfValBinder _    ty <- bndrs]
 300 \end{code}
 301
 302 \begin{code}
 303 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 304   = ASSERT( null names )
 305     tcCoreExpr rhs              `thenTc` \ rhs' ->
 306     returnTc (DEFAULT, [], rhs')
 307
 308 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 309   = ASSERT( null names )
 310     tcCoreExpr rhs              `thenTc` \ rhs' ->
 311     returnTc (LitAlt lit, [], rhs')
 312
 313 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 314   = ASSERT( null names )
 315     tcCoreExpr rhs              `thenTc` \ rhs' ->
 316     tcIfaceType ty              `thenTc` \ ty' ->
 317     returnTc (LitAlt (MachLitLit str ty'), [], rhs')
 318
 319 -- A case alternative is made quite a bit more complicated
 320 -- by the fact that we omit type annotations because we can
 321 -- work them out.  True enough, but its not that easy!
 322 tcCoreAlt scrut_ty alt@(con, names, rhs)
 323   = tcConAlt con        `thenTc` \ con ->
 324     let
 325         (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 326
 327         (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
 328                                     Just stuff -> stuff
 329                                     Nothing -> pprPanic "tcCoreAlt" (ppr alt)
 330         ex_tyvars'          = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 331         ex_tys'             = mkTyVarTys ex_tyvars'
 332         arg_tys             = dataConArgTys con (inst_tys ++ ex_tys')
 333         id_names            = drop (length ex_tyvars) names
 334         arg_ids
 335 #ifdef DEBUG
 336                 | length id_names /= length arg_tys
 337                 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 338                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 339                                          ppr arg_tys)
 340                 | otherwise
 341 #endif
 342                 = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
 343     in
 344     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
 345     tcExtendTyVarEnv ex_tyvars'                 $
 346     tcExtendGlobalValEnv arg_ids                $
 347     tcCoreExpr rhs                                      `thenTc` \ rhs' ->
 348     returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 349
 350
 351 tcConAlt :: UfConAlt Name -> TcM DataCon
 352 tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
 353   = returnTc (tupleCon boxity arity)
 354
 355 tcConAlt (UfDataAlt con_name)
 356   = tcVar con_name      `thenTc` \ con_id ->
 357     returnTc (case isDataConWrapId_maybe con_id of
 358                     Just con -> con
 359                     Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 360 \end{code}
 361
 362 \begin{code}
 363 ifaceSigCtxt sig_name
 364   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 365 \end{code}
 366