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