ghc/compiler/typecheck/Spec.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[Spec]{Specialisation of variables}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 One thing which happens {\em a lot} is the instantiation of a type scheme
  11 caused by the occurrence of a variable.  It is so important that it
  12 is written below in a very ``open-code'' fashion.  All the modular monadery
  13 is discarded, and we work directly in terms of the underlying representations.
  14 In particular, this function knows about
  15
  16         - the TcM monad
  17         - the representation of UniTypes
  18
  19 \begin{code}
  20 #include "HsVersions.h"
  21
  22 module Spec ( specId, specTy ) where
  23
  24 import AbsSyn
  25 import TcMonadFns       ( copyTyVars, newDicts )
  26 import TcMonad
  27
  28 import AbsUniType       {- ( instantiateTauTy, instantiateThetaTy,
  29                           cloneTyVarFromTemplate, splitType
  30                         ) -} -- pragmas want to see it all!
  31 import Id               ( getIdUniType, mkInstId, DictVar(..) )
  32 import Inst             -- ( mkMethod, InstOrigin(..), Inst, InstTemplate, SpecInfo )
  33 import LIE
  34 import Subst            ( getSubstTyVarUnique )
  35 import UniType          -- known **GRIEVOUS** violation of UniType abstractness!!!
  36 import SplitUniq
  37 import Unique
  38 import Util
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection[Spec-specId]{Instantiating an Id}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 @specId@ takes an @Id@ and implements the SPEC and REL rules
  48 returning
  49         - the id applied to suitable types and dictionaries
  50         - the LIE
  51         - its instantiated tau type
  52
  53 For efficiency, it knows about the TcM implementation.
  54
  55 \begin{code}
  56 specId :: Id -> NF_TcM (TypecheckedExpr, LIE, TauType)
  57
  58 specId id sw_chkr dtys subst uniq errs src_loc
  59   = case (spec_sigma subst uniq src_loc id (getIdUniType id)) of
  60       (result, subst2) -> (result, subst2, errs)
  61 \end{code}
  62
  63 \begin{code}
  64 spec_sigma :: Subst             -- TyVar unique supply inside *here*
  65            -> SplitUniqSupply   -- "normal" unique supply
  66            -> SrcLoc
  67            -> Id
  68            -> UniType
  69            -> ((TypecheckedExpr, LIE, TauType), Subst)
  70
  71 spec_sigma subst uniq src_loc id (UniSyn _ _ ty)
  72   = spec_sigma subst uniq src_loc id ty
  73
  74 spec_sigma subst uniq src_loc id ty@(UniForall _ _)
  75   = collect [] [] subst ty
  76   where
  77     collect tenv tyvar_tys subst (UniForall tyvar ty)
  78       = case (getSubstTyVarUnique subst) of
  79           (subst', u) ->
  80               collect ((tyvar, new_tyvar_ty) : tenv)
  81                       (new_tyvar_ty : tyvar_tys)
  82                       subst' ty
  83               where
  84                 new_tyvar_ty = UniTyVar (cloneTyVarFromTemplate tyvar u)
  85
  86     collect tenv tyvar_tys subst ty
  87       = spec_rho tenv (reverse tyvar_tys) subst uniq src_loc id ty
  88
  89 spec_sigma subst uniq src_loc id tau_ty
  90         -- Not polymorphic => cannot be overloaded
  91   = ((Var id, nullLIE, tau_ty), subst)
  92 \end{code}
  93
  94 \begin{code}
  95 spec_rho :: [(TyVarTemplate, UniType)] -> [UniType]
  96          -> Subst -> SplitUniqSupply -> SrcLoc
  97          -> Id -> UniType
  98          -> ((TypecheckedExpr, LIE, TauType), Subst)
  99
 100 spec_rho tenv tys subst uniqs src_loc id (UniSyn _ _ ty)
 101   = spec_rho tenv tys subst uniqs src_loc id ty
 102
 103 spec_rho tenv tys subst uniqs src_loc id (UniFun (UniDict _ _) ty)
 104   = ((Var inst_id, unitLIE method, instantiateTauTy tenv tau_ty),
 105      subst)
 106   where
 107     method  = mkMethod u id tys (OccurrenceOf id src_loc)
 108     inst_id = mkInstId method
 109     u       = getSUnique uniqs
 110     tau_ty  = discard_dicts ty
 111
 112     discard_dicts (UniFun (UniDict _ _) ty) = discard_dicts ty
 113     discard_dicts other_ty                  = other_ty
 114
 115 spec_rho tenv tys subst uniqs src_loc id tau_ty
 116   = ((TyApp (Var id) tys, nullLIE, instantiateTauTy tenv tau_ty),
 117      subst)
 118 \end{code}
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection[Spec-specTy]{Instantiating a type}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 @specTy@ takes a polymorphic type, and instantiates it with fresh type
 128 variables. It strips off the context part, gets fresh dictionary
 129 variables for each predicate in the context.  It returns
 130
 131         - a list of the dictionary variables (remember they contain
 132           their types)
 133         - an instantiated tau-type
 134
 135 The returned values are fixed points of the current substitution
 136 though the arguments may not be.
 137
 138 \begin{code}
 139 specTy :: InstOrigin -> SigmaType -> NF_TcM ([TyVar], [Inst], TauType)
 140
 141 specTy origin sigma_ty
 142   = let
 143         (old_tyvars, theta, tau_ty) = splitType sigma_ty
 144     in
 145          -- make new tyvars for each of the universally quantified type vars
 146     copyTyVars old_tyvars           `thenNF_Tc` \ (inst_env, new_tyvars, _) ->
 147
 148          -- instantiate the tau type
 149     let
 150         tau_ty' = instantiateTauTy inst_env tau_ty
 151     in
 152          -- instantiate the dictionary types
 153     newDicts origin (instantiateThetaTy inst_env theta) `thenNF_Tc` \ dicts ->
 154
 155          -- return the list of tyvars, the list of dicts and the tau type
 156     returnNF_Tc ( new_tyvars, dicts, tau_ty' )
 157 \end{code}
 158