ghc/compiler/typecheck/TcMonadFns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcMonadFns]{Auxilliary functions for typechecker monad}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMonadFns (
  10         newDict, newDicts, newMethod, newOverloadedLit,
  11
  12         copyTyVars,
  13         newOpenTyVarTy, newPolyTyVarTy,
  14         newPolyTyVarTys,
  15
  16 --UNUSED:       newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy,
  17         newLocalWithGivenTy,
  18         newSpecPragmaId, newSpecId,
  19         newClassOpLocals,
  20         newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys,
  21
  22         mkIdsWithOpenTyVarTys, mkIdsWithPolyTyVarTys,
  23         mkIdsWithGivenTys,
  24
  25         applyTcSubstAndCollectTyVars,
  26         applyTcSubstAndExpectTyVars,
  27
  28         -- and to make the interface self-sufficient...
  29         Bag, Class, Binds, MonoBinds, TypecheckedPat, Id, Inst, SpecInfo,
  30         OverloadedLit, InstOrigin, TcResult, Name, SrcLoc, Subst, Maybe,
  31         Error(..), TyVar, UniType, UnifyErrContext, UniqueSupply,
  32         PprStyle, Pretty(..), PrettyRep
  33     ) where
  34
  35 import TcMonad          -- the underlying monadery
  36 import AbsSyn
  37
  38 import AbsUniType
  39 import Id               ( mkId, mkUserLocal, mkSpecPragmaId, mkSpecId, Id, DictVar(..) )
  40 import IdInfo
  41 import Inst             ( mkDict, mkMethod, mkLitInst,
  42                           Inst(..), -- .. for pragmas
  43                           OverloadedLit, InstOrigin
  44                         )
  45 import Maybes           ( Maybe(..) )
  46 import E                ( LVE(..) )
  47 import Errors           ( Error(..), UnifyErrInfo )
  48 import Unique           ( Unique, UniqueSupply )
  49 import Util
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection[TcMonadFns-newNameThings]{Making new things from the name supply}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 @newPolyTyVars@ takes list of ``old'' template type vars, and manufactures
  59 a list of freshly-uniqued type vars.
  60
  61 \begin{code}
  62 copyTyVars :: [TyVarTemplate]           -- Old type vars
  63            -> NF_TcM
  64                 ([(TyVarTemplate,TauType)],--Old-to-new assoc list
  65                  [TyVar],               -- New type vars
  66                  [TauType])             -- New type vars wrapped in a UniTyVar
  67
  68 copyTyVars old_tyvars
  69   = getTyVarUniquesTc (length old_tyvars) `thenNF_Tc` \ new_uniqs ->
  70     returnNF_Tc (instantiateTyVarTemplates old_tyvars new_uniqs)
  71
  72 newOpenTyVarTys :: Int -> NF_TcM [UniType]
  73 newOpenTyVarTys n
  74   = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs ->
  75     returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs]
  76
  77 newPolyTyVarTys :: Int -> NF_TcM [UniType]
  78 newPolyTyVarTys n
  79   = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs ->
  80     returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs]
  81
  82 newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType
  83 newOpenTyVarTy
  84   = getTyVarUniqueTc `thenNF_Tc` \ new_uniq ->
  85     returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq))
  86
  87 newPolyTyVarTy
  88   = getTyVarUniqueTc `thenNF_Tc` \ new_uniq ->
  89     returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq))
  90 \end{code}
  91
  92 The functions @newDicts@, @newMethod@, and @newOverloadedLit@ build
  93 new @Inst@s.
  94
  95 \begin{code}
  96 newDicts :: InstOrigin -> ThetaType -> NF_TcM [Inst]
  97 newDicts orig theta
  98  = getUniquesTc (length theta)          `thenNF_Tc` \ new_uniqs ->
  99    returnNF_Tc (zipWith mk_dict_var new_uniqs theta)
 100  where
 101    mk_dict_var u (clas, ty) = mkDict u clas ty orig
 102
 103 newDict :: InstOrigin -> Class -> UniType -> NF_TcM Inst
 104 newDict orig clas ty
 105  = getUniqueTc          `thenNF_Tc` \ new_uniq ->
 106    returnNF_Tc (mkDict new_uniq clas ty orig)
 107
 108 newMethod :: InstOrigin -> Id -> [UniType] -> NF_TcM Inst
 109 newMethod orig id tys
 110  = getUniqueTc                  `thenNF_Tc` \ new_uniq ->
 111    returnNF_Tc (mkMethod new_uniq id tys orig)
 112
 113 newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> NF_TcM Inst
 114 newOverloadedLit orig lit ty
 115  = getUniqueTc                  `thenNF_Tc` \ new_uniq ->
 116    returnNF_Tc (mkLitInst new_uniq lit ty orig)
 117 \end{code}
 118
 119 Make a fresh batch of locals, derived from name, each typed with a fresh
 120 type variable, and return an LVE of them.
 121 \begin{itemize}
 122
 123 \item   @mkIdsWithTyVarTys@ uses the supplied names directly (including their
 124         uniques), and generates a @TopId@ or @Local@ depending on whether
 125         the name is a @FullName@ or not.
 126
 127 \item   @mkIdsWithGivenTys@ does as above, but the types are supplied.
 128 \end{itemize}
 129
 130 \begin{code}
 131 mkIdsWithPolyTyVarTys, mkIdsWithOpenTyVarTys :: [Name] -> NF_TcM LVE
 132 mkIdsWithPolyTyVarTys names
 133   = let
 134         no_of_names = length names
 135     in
 136     newPolyTyVarTys no_of_names  `thenNF_Tc` \ tys ->
 137     returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
 138
 139 mkIdsWithOpenTyVarTys names
 140   = let
 141         no_of_names = length names
 142     in
 143     newOpenTyVarTys no_of_names  `thenNF_Tc` \ tys ->
 144     returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
 145
 146 mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> LVE
 147     -- not monadic any more (WDP 94/05)
 148     -- Not done w/ zips/etc for "efficiency" (?)
 149 mkIdsWithGivenTys [] [] _ = []
 150 mkIdsWithGivenTys (name:names) (ty:tys) (id_info:id_infos)
 151   = (name, mkId name ty id_info) : mkIdsWithGivenTys names tys id_infos
 152
 153 newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys  :: [Name] -> NF_TcM [Id]
 154 newLocalsWithOpenTyVarTys = new_locals_given_tyvar_fun newOpenTyVarTys
 155 newLocalsWithPolyTyVarTys = new_locals_given_tyvar_fun newPolyTyVarTys
 156
 157 new_locals_given_tyvar_fun new_tyvar_fun names
 158   = new_tyvar_fun no_of_names           `thenNF_Tc` \ tys ->
 159     getUniquesTc no_of_names            `thenNF_Tc` \ uniqs ->
 160     let  ids = zipWith3 mk_local names uniqs tys  in
 161     returnNF_Tc ids
 162   where
 163     no_of_names = length names
 164     mk_local name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
 165                                         (getSrcLoc name)
 166 \end{code}
 167
 168 @newLocal*@ creates a new unique local variable with the given
 169 string and type. @newLocals@ is similar, but works on lists of strings
 170 and types.
 171
 172 \begin{code}
 173 {- UNUSED:
 174 newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy  :: Name -> NF_TcM Id
 175
 176 newLocalWithOpenTyVarTy name
 177   = newOpenTyVarTy      `thenNF_Tc` \ ty ->
 178     newLocalWithGivenTy name ty
 179
 180 newLocalWithPolyTyVarTy name
 181   = newPolyTyVarTy      `thenNF_Tc` \ ty ->
 182     newLocalWithGivenTy name ty
 183 -}
 184
 185 newLocalWithGivenTy :: Name -> UniType -> NF_TcM Id
 186 newLocalWithGivenTy name ty
 187   = getUniqueTc         `thenNF_Tc` \ uniq ->
 188     returnNF_Tc (mkUserLocal (getOccurrenceName name) uniq ty (getSrcLoc name))
 189
 190 newSpecPragmaId :: Name -> UniType -> Maybe SpecInfo -> NF_TcM Id
 191 newSpecPragmaId name ty specinfo
 192   = getUniqueTc         `thenNF_Tc` \ uniq ->
 193     returnNF_Tc (mkSpecPragmaId (getOccurrenceName name) uniq ty specinfo (getSrcLoc name))
 194
 195 newSpecId :: Id -> [Maybe UniType] -> UniType -> NF_TcM Id
 196 newSpecId unspec spec_tys ty
 197   = getUniqueTc         `thenNF_Tc` \ uniq ->
 198     returnNF_Tc (mkSpecId uniq unspec spec_tys ty noIdInfo)
 199 \end{code}
 200
 201 ToDo: This @newClassOpLocals@ is used only to make new ClassOps.  Pretty yukky.
 202
 203 \begin{code}
 204 newClassOpLocals :: [(TyVarTemplate, TauType)]
 205                                         -- The class type variable mapped to
 206                                         -- the instance type (an InstTyEnv)
 207                  -> [ClassOp]           -- The class ops
 208                  -> NF_TcM [Id]         -- Suitable Ids for the polymorphic
 209                                         -- methods
 210 newClassOpLocals inst_env ops
 211   = getSrcLocTc                         `thenNF_Tc` \ src_loc ->
 212     getUniquesTc (length ops)           `thenNF_Tc` \ uniqs ->
 213     returnNF_Tc (zipWith (new_local src_loc) ops uniqs)
 214   where
 215     new_local src_loc op uniq
 216       = mkUserLocal (getClassOpString op)
 217                     uniq
 218                     (instantiateTy inst_env (getClassOpLocalType op))
 219                     src_loc
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 Back-substitution functions.  These just apply the current
 225 substitution to their argument(s).
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 @applyTcSubstAndCollectTyVars@ applies a substitution to a list of type
 230 variables, takes the free type vars of the resulting types, and
 231 returns all of them as list without duplications.
 232
 233 \begin{code}
 234 applyTcSubstAndCollectTyVars :: [TyVar] -> NF_TcM [TyVar]
 235 applyTcSubstAndCollectTyVars tyvars
 236   = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
 237     returnNF_Tc (extractTyVarsFromTys tys)
 238
 239 applyTcSubstAndExpectTyVars :: [TyVar] -> NF_TcM [TyVar]
 240 applyTcSubstAndExpectTyVars tyvars
 241   = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
 242     returnNF_Tc (map (getTyVar "applyTcSubstAndExpectTyVars") tys)
 243 \end{code}