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 )
  15 import TcEnv            ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv )
  16 import TcKind           ( TcKind, kindToTcKind )
  17
  18 import HsSyn            ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
  19                           Fake, InPat, HsType )
  20 import RnHsSyn          ( RenamedHsDecl(..) )
  21 import HsCore
  22 import HsDecls          ( HsIdInfo(..) )
  23 import CoreSyn
  24 import CoreUnfold
  25 import MagicUFs         ( MagicUnfoldingFun )
  26 import SpecEnv          ( SpecEnv )
  27 import PrimOp           ( PrimOp(..) )
  28
  29 import Id               ( GenId, mkImported, mkUserId, isPrimitiveId_maybe )
  30 import TyVar            ( mkTyVar )
  31 import Name             ( Name )
  32 import PragmaInfo       ( PragmaInfo(..) )
  33 import Maybes           ( maybeToBool )
  34 import Pretty
  35 import PprStyle         ( PprStyle(..) )
  36 import Util             ( zipWithEqual, panic, pprTrace, pprPanic )
  37
  38 import IdInfo
  39 \end{code}
  40
  41 Ultimately, type signatures in interfaces will have pragmatic
  42 information attached, so it is a good idea to have separate code to
  43 check them.
  44
  45 As always, we do not have to worry about user-pragmas in interface
  46 signatures.
  47
  48 \begin{code}
  49 tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
  50                    -- Ignore non-sig-decls in these decls
  51
  52 tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
  53   = tcAddSrcLoc src_loc $
  54     tcHsType ty                         `thenTc` \ sigma_ty ->
  55     tcIdInfo name noIdInfo id_infos     `thenTc` \ id_info' ->
  56     let
  57         sig_id = mkImported name sigma_ty id_info'
  58     in
  59     tcInterfaceSigs rest                `thenTc` \ sig_ids ->
  60     returnTc (sig_id : sig_ids)
  61
  62 tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
  63
  64 tcInterfaceSigs [] = returnTc []
  65 \end{code}
  66
  67 Inside here we use only the Global environment, even for locally bound variables.
  68 Why? Because we know all the types and want to bind them to real Ids.
  69
  70 \begin{code}
  71 tcIdInfo name info [] = returnTc info
  72
  73 tcIdInfo name info (HsArity arity : rest)
  74   = tcIdInfo name (info `addArityInfo` arity) rest
  75
  76 tcIdInfo name info (HsUpdate upd : rest)
  77   = tcIdInfo name (info `addUpdateInfo` upd) rest
  78
  79 tcIdInfo name info (HsFBType fb : rest)
  80   = tcIdInfo name (info `addFBTypeInfo` fb) rest
  81
  82 tcIdInfo name info (HsArgUsage au : rest)
  83   = tcIdInfo name (info `addArgUsageInfo` au) rest
  84
  85 tcIdInfo name info (HsDeforest df : rest)
  86   = tcIdInfo name (info `addDeforestInfo` df) rest
  87
  88 tcIdInfo name info (HsUnfold expr : rest)
  89   = tcUnfolding name expr       `thenNF_Tc` \ unfold_info ->
  90     tcIdInfo name (info `addUnfoldInfo` unfold_info) rest
  91
  92 tcIdInfo name info (HsStrictness strict : rest)
  93   = tcStrictness strict         `thenTc` \ strict_info ->
  94     tcIdInfo name (info `addStrictnessInfo` strict_info) rest
  95 \end{code}
  96
  97 \begin{code}
  98 tcStrictness (StrictnessInfo demands (Just worker))
  99   = tcLookupGlobalValue worker          `thenNF_Tc` \ worker_id ->
 100     returnTc (StrictnessInfo demands (Just worker_id))
 101
 102 -- Boring to write these out, but the result type differe from the arg type...
 103 tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
 104 tcStrictness NoStrictnessInfo                 = returnTc NoStrictnessInfo
 105 tcStrictness BottomGuaranteed                 = returnTc BottomGuaranteed
 106 \end{code}
 107
 108 For unfoldings we try to do the job lazily, so that we never type check
 109 an unfolding that isn't going to be looked at.
 110
 111 \begin{code}
 112 tcUnfolding name core_expr
 113   = forkNF_Tc (
 114         recoverNF_Tc (returnNF_Tc no_unfolding) (
 115                 tcCoreExpr core_expr    `thenTc` \ core_expr' ->
 116                 returnTc (mkUnfolding False core_expr')
 117     ))
 118   where
 119     no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding
 120 \end{code}
 121
 122 UfCore expressions.
 123
 124 \begin{code}
 125 tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
 126
 127 tcCoreExpr (UfVar name)
 128   = tcLookupGlobalValue name    `thenNF_Tc` \ id ->
 129     returnTc (Var id)
 130
 131 tcCoreExpr (UfLit lit) = returnTc (Lit lit)
 132
 133 tcCoreExpr (UfCon con args)
 134   = tcLookupGlobalValue con     `thenNF_Tc` \ con_id ->
 135     mapTc tcCoreArg args        `thenTc` \ args' ->
 136     returnTc (Con con_id args')
 137
 138 tcCoreExpr (UfPrim prim args)
 139   = tcCorePrim prim             `thenTc` \ primop ->
 140     mapTc tcCoreArg args        `thenTc` \ args' ->
 141     returnTc (Prim primop args')
 142
 143 tcCoreExpr (UfApp fun arg)
 144   = tcCoreExpr fun              `thenTc` \ fun' ->
 145     tcCoreArg arg               `thenTc` \ arg' ->
 146     returnTc (App fun' arg')
 147
 148 tcCoreExpr (UfCase scrut alts)
 149   = tcCoreExpr scrut            `thenTc` \ scrut' ->
 150     tcCoreAlts alts             `thenTc` \ alts' ->
 151     returnTc (Case scrut' alts')
 152
 153 tcCoreExpr (UfSCC cc expr)
 154   = tcCoreExpr expr             `thenTc` \ expr' ->
 155     returnTc  (SCC cc expr')
 156
 157 tcCoreExpr(UfCoerce coercion ty body)
 158   = tcCoercion coercion         `thenTc` \ coercion' ->
 159     tcHsType ty                 `thenTc` \ ty' ->
 160     tcCoreExpr body             `thenTc` \ body' ->
 161     returnTc (Coerce coercion' ty' body')
 162
 163 tcCoreExpr (UfLam bndr body)
 164   = tcCoreLamBndr bndr          $ \ bndr' ->
 165     tcCoreExpr body             `thenTc` \ body' ->
 166     returnTc (Lam bndr' body')
 167
 168 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 169   = tcCoreExpr rhs              `thenTc` \ rhs' ->
 170     tcCoreValBndr bndr          $ \ bndr' ->
 171     tcCoreExpr body             `thenTc` \ body' ->
 172     returnTc (Let (NonRec bndr' rhs') body')
 173
 174 tcCoreExpr (UfLet (UfRec pairs) body)
 175   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 176     mapTc tcCoreExpr rhss       `thenTc` \ rhss' ->
 177     tcCoreExpr body             `thenTc` \ body' ->
 178     returnTc (Let (Rec (bndrs' `zip` rhss')) body')
 179   where
 180     (bndrs, rhss) = unzip pairs
 181 \end{code}
 182
 183 \begin{code}
 184 tcCoreLamBndr (UfValBinder name ty) thing_inside
 185   = tcHsType ty                 `thenTc` \ ty' ->
 186     let
 187         id = mkUserId name ty' NoPragmaInfo
 188     in
 189     tcExtendGlobalValEnv [id] $
 190     thing_inside (ValBinder id)
 191
 192 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 193   = let
 194         tyvar = mkTyVar name kind
 195     in
 196     tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
 197     thing_inside (TyBinder tyvar)
 198
 199 tcCoreLamBndr (UfUsageBinder name) thing_inside
 200   = error "tcCoreLamBndr: usage"
 201
 202 tcCoreValBndr (UfValBinder name ty) thing_inside
 203   = tcHsType ty                 `thenTc` \ ty' ->
 204     let
 205         id = mkUserId name ty' NoPragmaInfo
 206     in
 207     tcExtendGlobalValEnv [id] $
 208     thing_inside id
 209
 210 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 211   = mapTc tcHsType tys                  `thenTc` \ tys' ->
 212     let
 213         ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
 214         mk_id name ty' = mkUserId name ty' NoPragmaInfo
 215     in
 216     tcExtendGlobalValEnv ids $
 217     thing_inside ids
 218   where
 219     names = map (\ (UfValBinder name _) -> name) bndrs
 220     tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
 221 \end{code}
 222
 223 \begin{code}
 224 tcCoreArg (UfVarArg v)   = tcLookupGlobalValue v  `thenNF_Tc` \ v' -> returnTc (VarArg v')
 225 tcCoreArg (UfTyArg ty)   = tcHsType ty            `thenTc` \ ty' -> returnTc (TyArg ty')
 226 tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
 227 tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
 228
 229 tcCoreAlts (UfAlgAlts alts deflt)
 230   = mapTc tc_alt alts           `thenTc` \ alts' ->
 231     tcCoreDefault deflt         `thenTc` \ deflt' ->
 232     returnTc (AlgAlts alts' deflt')
 233   where
 234     tc_alt (con, bndrs, rhs) =  tcLookupGlobalValue con         `thenNF_Tc` \ con' ->
 235                                 tcCoreValBndrs bndrs            $ \ bndrs' ->
 236                                 tcCoreExpr rhs                  `thenTc` \ rhs' ->
 237                                 returnTc (con', bndrs', rhs')
 238
 239 tcCoreAlts (UfPrimAlts alts deflt)
 240   = mapTc tc_alt alts           `thenTc` \ alts' ->
 241     tcCoreDefault deflt         `thenTc` \ deflt' ->
 242     returnTc (PrimAlts alts' deflt')
 243   where
 244     tc_alt (lit, rhs) = tcCoreExpr rhs          `thenTc` \ rhs' ->
 245                         returnTc (lit, rhs')
 246
 247 tcCoreDefault UfNoDefault = returnTc NoDefault
 248 tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr     $ \ bndr' ->
 249                                          tcCoreExpr rhs         `thenTc` \ rhs' ->
 250                                          returnTc (BindDefault bndr' rhs')
 251
 252 tcCoercion (UfIn  n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn  n')
 253 tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n')
 254
 255 tcCorePrim (UfOtherOp op)
 256   = tcLookupGlobalValue op      `thenNF_Tc` \ op_id ->
 257     case isPrimitiveId_maybe op_id of
 258         Just prim_op -> returnTc prim_op
 259         Nothing      -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
 260
 261 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
 262   = mapTc tcHsType arg_tys      `thenTc` \ arg_tys' ->
 263     tcHsType res_ty             `thenTc` \ res_ty' ->
 264     returnTc (CCallOp str casm gc arg_tys' res_ty')
 265 \end{code}
 266