Commit 5a8ac0f8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify the implementation of Implicit Parameters

This patch re-implements implicit parameters via a class
with a functional dependency:

    class IP (n::Symbol) a | n -> a where
      ip :: a

This definition is in the library module GHC.IP. Notice
how it use a type-literal, so we can have constraints like
   IP "x" Int
Now all the functional dependency machinery works right to make
implicit parameters behave as they should.

Much special-case processing for implicit parameters can be removed
entirely. One particularly nice thing is not having a dedicated
"original-name cache" for implicit parameters (the nsNames field of
NameCache).  But many other cases disappear:

  * BasicTypes.IPName
  * IPTyCon constructor in Tycon.TyCon
  * CIPCan constructor  in TcRnTypes.Ct
  * IPPred constructor  in Types.PredTree

Implicit parameters remain special in a few ways:

 * Special syntax.  Eg the constraint (IP "x" Int) is parsed
   and printed as (?x::Int).  And we still have local bindings
   for implicit parameters, and occurrences thereof.

 * A implicit-parameter binding  (let ?x = True in e) amounts
   to a local instance declaration, which we have not had before.
   It just generates an implication contraint (easy), but when
   going under it we must purge any existing bindings for
   ?x in the inert set.  See Note [Shadowing of Implicit Parameters]
   in TcSimplify

 * TcMType.sizePred classifies implicit parameter constraints as size-0,
   as before the change

There are accompanying patches to libraries 'base' and 'haddock'

All the work was done by Iavor Diatchki
parent 03f78f06
......@@ -39,8 +39,6 @@ module BasicTypes(
negateFixity, funTyFixity,
compareFixity,
IPName(..), ipNameName, mapIPName,
RecFlag(..), isRec, isNonRec, boolToRecFlag,
RuleName,
......@@ -176,32 +174,6 @@ instance Outputable WarningTxt where
doubleQuotes (vcat (map ftext ds))
\end{code}
%************************************************************************
%* *
\subsection{Implicit parameter identity}
%* *
%************************************************************************
The @IPName@ type is here because it is used in TypeRep (i.e. very
early in the hierarchy), but also in HsSyn.
\begin{code}
newtype IPName name = IPName name -- ?x
deriving( Eq, Data, Typeable )
instance Functor IPName where
fmap = mapIPName
ipNameName :: IPName name -> name
ipNameName (IPName n) = n
mapIPName :: (a->b) -> IPName a -> IPName b
mapIPName f (IPName n) = IPName (f n)
instance Outputable name => Outputable (IPName name) where
ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
\end{code}
%************************************************************************
%* *
Rules
......
......@@ -179,9 +179,6 @@ instance Uniquable FastString where
instance Uniquable Int where
getUnique i = mkUniqueGrimily i
instance Uniquable n => Uniquable (IPName n) where
getUnique (IPName n) = getUnique n
\end{code}
......
......@@ -25,9 +25,6 @@ module MkCore (
-- * Floats
FloatBind(..), wrapFloat,
-- * Constructing/deconstructing implicit parameter boxes
mkIPUnbox, mkIPBox,
-- * Constructing/deconstructing equality evidence boxes
mkEqBox,
......@@ -62,7 +59,7 @@ module MkCore (
#include "HsVersions.h"
import Id
import Var ( IpId, EvVar, setTyVarUnique )
import Var ( EvVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
......@@ -72,8 +69,7 @@ import HscTypes
import TysWiredIn
import PrelNames
import IParam ( ipCoAxiom )
import TcType ( mkSigmaTy, evVarPred )
import TcType ( mkSigmaTy )
import Type
import Coercion
import TysPrim
......@@ -303,21 +299,6 @@ mkStringExprFS str
\begin{code}
mkIPBox :: IPName IpId -> CoreExpr -> CoreExpr
mkIPBox ipx e = e `Cast` mkSymCo (mkAxInstCo (ipCoAxiom ip) [ty])
where x = ipNameName ipx
Just (ip, ty) = getIPPredTy_maybe (evVarPred x)
-- NB: don't use the DataCon work id because we don't generate code for it
mkIPUnbox :: IPName IpId -> CoreExpr
mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty]
where x = ipNameName ipx
Just (ip, ty) = getIPPredTy_maybe (evVarPred x)
\end{code}
\begin{code}
mkEqBox :: Coercion -> CoreExpr
mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) )
Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co
......
......@@ -86,9 +86,9 @@ dsIPBinds (IPBinds ip_binds ev_binds) body
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind n e)) body
ds_ip_bind (L _ (IPBind ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec (ipNameName n) (mkIPBox n e')) body)
return (Let (NonRec n e') body)
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
......@@ -188,7 +188,7 @@ dsExpr :: HsExpr Id -> DsM CoreExpr
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
dsExpr (HsIPVar ip) = return (mkIPUnbox ip)
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
......
......@@ -404,7 +404,6 @@ Library
TcCanonical
TcSMonad
Class
IParam
Coercion
FamInstEnv
FunDeps
......
......@@ -416,10 +416,12 @@ isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
type LIPBind id = Located (IPBind id)
-- | Implicit parameter bindings.
{- These bindings start off as (Left "x") in the parser and stay
that way until after type-checking when they are replaced with
(Right d), where "d" is the name of the dictionary holding the
evidene for the implicit parameter. -}
data IPBind id
= IPBind
(IPName id)
(LHsExpr id)
= IPBind (Either HsIPName id) (LHsExpr id)
deriving (Data, Typeable)
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
......@@ -427,7 +429,10 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where
$$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left ip -> pprBndr LetBind ip
Right id -> pprBndr LetBind id
\end{code}
......
......@@ -106,7 +106,7 @@ noSyntaxTable = []
-- | A Haskell expression.
data HsExpr id
= HsVar id -- ^ variable
| HsIPVar (IPName id) -- ^ implicit parameter
| HsIPVar HsIPName -- ^ implicit parameter
| HsOverLit (HsOverLit id) -- ^ Overloaded literals
| HsLit HsLit -- ^ Simple (non-overloaded) literals
......
......@@ -18,6 +18,7 @@ module HsTypes (
HsQuasiQuote(..),
HsTyWrapper(..),
HsTyLit(..),
HsIPName(..), hsIPNameFS,
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
......@@ -158,6 +159,24 @@ mkHsWithBndrs :: thing -> HsWithBndrs thing
mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
, hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
-- | These names are used eary on to store the names of implicit
-- parameters. They completely disappear after type-checking.
newtype HsIPName = HsIPName FastString-- ?x
deriving( Eq, Data, Typeable )
hsIPNameFS :: HsIPName -> FastString
hsIPNameFS (HsIPName n) = n
instance Outputable HsIPName where
ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters
instance OutputableBndr HsIPName where
pprBndr _ n = ppr n -- Simple for now
pprInfixOcc n = ppr n
pprPrefixOcc n = ppr n
data HsTyVarBndr name
= UserTyVar -- No explicit kinding
name -- See Note [Printing KindedTyVars]
......@@ -201,7 +220,7 @@ data HsType name
-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
| HsIParamTy (IPName name) -- (?x :: ty)
| HsIParamTy HsIPName -- (?x :: ty)
(LHsType name) -- Implicit parameters as they occur in contexts
| HsEqTy (LHsType name) -- ty1 ~ ty2
......
......@@ -19,9 +19,8 @@ module BinIface (
#include "HsVersions.h"
import TcRnMonad
import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon, tyConIP_maybe)
import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon)
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import IParam (ipFastString, ipTyConName)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
import TysWiredIn
......@@ -316,7 +315,7 @@ knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName dict BinSymbolTable{
putName _dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next } bh name
| name `elemUFM` knownKeyNamesMap
......@@ -327,10 +326,6 @@ putName dict BinSymbolTable{
= case wiredInNameTyThing_maybe name of
Just (ATyCon tc)
| isTupleTyCon tc -> putTupleName_ bh tc 0
| Just ip <- tyConIP_maybe tc -> do
off <- allocateFastString dict (ipFastString ip)
-- MASSERT(off < 2^(30 :: Int))
put_ bh (0xC0000000 .|. off)
Just (ADataCon dc)
| let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
Just (AnId x)
......@@ -362,7 +357,7 @@ putTupleName_ bh tc thing_tag
getSymtabName :: NameCacheUpdater
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName ncu dict symtab bh = do
getSymtabName _ncu _dict symtab bh = do
i <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral (i ::  Word32)
......@@ -385,7 +380,6 @@ getSymtabName ncu dict symtab bh = do
_ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26
arity = fromIntegral (i .&. 0x03FFFFFF)
0xC0000000 -> liftM ipTyConName $ updateNameCache ncu $ flip allocateIPName (dict ! fromIntegral (i .&. 0x3FFFFFFF))
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
data BinSymbolTable = BinSymbolTable {
......@@ -426,7 +420,6 @@ data BinDictionary = BinDictionary {
-- All the binary instances
-- BasicTypes
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for FixityDirection derive: Binary !-}
{-! for Boxity derive: Binary !-}
......@@ -825,11 +818,6 @@ instance Binary Fixity where
ab <- get bh
return (Fixity aa ab)
instance (Binary name) => Binary (IPName name) where
put_ bh (IPName aa) = put_ bh aa
get bh = do aa <- get bh
return (IPName aa)
-------------------------------------------------------------------------
-- Types from: Demand
-------------------------------------------------------------------------
......@@ -1057,8 +1045,7 @@ instance Binary IfaceCoCon where
put_ bh IfaceTransCo = putByte bh 4
put_ bh IfaceInstCo = putByte bh 5
put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
put_ bh (IfaceIPCoAx ip) = do { putByte bh 7; put_ bh ip }
get bh = do
h <- getByte bh
case h of
......@@ -1069,7 +1056,6 @@ instance Binary IfaceCoCon where
4 -> return IfaceTransCo
5 -> return IfaceInstCo
6 -> do { d <- get bh; return (IfaceNthCo d) }
7 -> do { ip <- get bh; return (IfaceIPCoAx ip) }
_ -> panic ("get IfaceCoCon " ++ show h)
-------------------------------------------------------------------------
......
......@@ -12,14 +12,14 @@ module IfaceEnv (
newGlobalBinder, newImplicitBinder,
lookupIfaceTop,
lookupOrig, lookupOrigNameCache, extendNameCache,
newIPName, newIfaceName, newIfaceNames,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
ifaceExportNames,
-- Name-cache stuff
allocateGlobalBinder, allocateIPName, initNameCache, updNameCache,
allocateGlobalBinder, initNameCache, updNameCache,
getNameCache, mkNameCacheUpdater, NameCacheUpdater(..)
) where
......@@ -40,14 +40,12 @@ import UniqFM
import FastString
import UniqSupply
import SrcLoc
import BasicTypes
import Util
import Outputable
import Exception ( evaluate )
import Data.IORef ( atomicModifyIORef, readIORef )
import qualified Data.Map as Map
\end{code}
......@@ -165,21 +163,6 @@ lookupOrig mod occ
new_cache = extendNameCache (nsNames name_cache) mod occ name
in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
}}}
allocateIPName :: NameCache -> FastString -> (NameCache, IPName Name)
allocateIPName name_cache ip = case Map.lookup ip ipcache of
Just name_ip -> (name_cache, name_ip)
Nothing -> (new_ns, name_ip)
where
(us_here, us') = splitUniqSupply (nsUniqs name_cache)
tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
name_ip = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u
new_ipcache = Map.insert ip name_ip ipcache
new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache}
where ipcache = nsIPs name_cache
newIPName :: FastString -> TcRnIf m n (IPName Name)
newIPName ip = updNameCache $ flip allocateIPName ip
\end{code}
%************************************************************************
......@@ -249,8 +232,7 @@ mkNameCacheUpdater = do
initNameCache :: UniqSupply -> [Name] -> NameCache
initNameCache us names
= NameCache { nsUniqs = us,
nsNames = initOrigNames names,
nsIPs = Map.empty }
nsNames = initOrigNames names }
initOrigNames :: [Name] -> OrigNameCache
initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
......
......@@ -14,7 +14,7 @@ This module defines interface types and binders
-- for details
module IfaceType (
IfExtName, IfLclName, IfIPName,
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
IfaceTyLit(..),
......@@ -37,8 +37,6 @@ module IfaceType (
import Coercion
import TypeRep hiding( maybeParen )
import Type (tyConAppTyCon_maybe)
import IParam (ipFastString)
import TyCon
import Id
import Var
......@@ -62,8 +60,6 @@ type IfLclName = FastString -- A local name in iface syntax
type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn
-- (However Internal or System Names never should)
type IfIPName = FastString -- Represent implicit parameters simply as a string
data IfaceBndr -- Local (non-top-level) binders
= IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
| IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
......@@ -99,7 +95,6 @@ newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
-- Coercion constructors
data IfaceCoCon
= IfaceCoAx IfExtName
| IfaceIPCoAx FastString
| IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
| IfaceTransCo | IfaceInstCo
| IfaceNthCo Int
......@@ -253,10 +248,6 @@ ppr_tc_app _ (IfaceTc n) tys
, Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
= tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
| Just (ATyCon tc) <- wiredInNameTyThing_maybe n
, Just ip <- tyConIP_maybe tc
, [ty] <- tys
= parens (ppr ip <> dcolon <> pprIfaceType ty)
ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
......@@ -279,7 +270,6 @@ instance Outputable IfaceTyCon where
instance Outputable IfaceCoCon where
ppr (IfaceCoAx n) = ppr n
ppr (IfaceIPCoAx ip) = ppr (IPName ip)
ppr IfaceReflCo = ptext (sLit "Refl")
ppr IfaceUnsafeCo = ptext (sLit "Unsafe")
ppr IfaceSymCo = ptext (sLit "Sym")
......@@ -386,11 +376,6 @@ coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
, toIfaceType ty ]
coAxiomToIfaceType :: CoAxiom -> IfaceCoCon
coAxiomToIfaceType con
| Just tc <- tyConAppTyCon_maybe (co_ax_lhs con)
, Just ip <- tyConIP_maybe tc
= IfaceIPCoAx (ipFastString ip)
| otherwise
= IfaceCoAx (coAxiomName con)
coAxiomToIfaceType con = IfaceCoAx (coAxiomName con)
\end{code}
......@@ -37,7 +37,6 @@ import Id
import MkId
import IdInfo
import Class
import IParam
import TyCon
import DataCon
import PrelNames
......@@ -958,7 +957,6 @@ tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
tcIfaceCoApp (IfaceIPCoAx ip) ts = AxiomInstCo <$> liftM ipCoAxiom (newIPName ip) <*> mapM tcIfaceCo ts
tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
......
......@@ -2174,6 +2174,11 @@ impliedFlags
, (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields)
, (Opt_ParallelArrays, turnOn, Opt_ParallelListComp)
-- An implicit parameter constraint, `?x::Int`, is desugared into
-- `IP "x" Int`, which requires a flexible context/instance.
, (Opt_ImplicitParams, turnOn, Opt_FlexibleContexts)
, (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances)
]
optLevelFlags :: [([Int], DynFlag)]
......
......@@ -73,7 +73,7 @@ module HscTypes (
-- * Information on imports and exports
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
NameCache(..), OrigNameCache, OrigIParamCache,
NameCache(..), OrigNameCache,
IfaceExport,
-- * Warnings
......@@ -162,7 +162,6 @@ import Util
import Control.Monad ( mplus, guard, liftM, when )
import Data.Array ( Array, array )
import Data.IORef
import Data.Map ( Map )
import Data.Time
import Data.Word
import Data.Typeable ( Typeable )
......@@ -1763,17 +1762,12 @@ its binding site, we fix it up.
data NameCache
= NameCache { nsUniqs :: UniqSupply,
-- ^ Supply of uniques
nsNames :: OrigNameCache,
nsNames :: OrigNameCache
-- ^ Ensures that one original name gets one unique
nsIPs :: OrigIParamCache
-- ^ Ensures that one implicit parameter name gets one unique
}
-- | Per-module cache of original 'OccName's given 'Name's
type OrigNameCache = ModuleEnv (OccEnv Name)
-- | Module-local cache of implicit parameter 'OccName's given 'Name's
type OrigIParamCache = Map FastString (IPName Name)
\end{code}
......
......@@ -1762,10 +1762,10 @@ dbinds :: { Located [LIPBind RdrName] }
-- | {- empty -} { [] }
dbind :: { LIPBind RdrName }
dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) }
dbind : ipvar '=' exp { LL (IPBind (Left (unLoc $1)) $3) }
ipvar :: { Located (IPName RdrName) }
: IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) }
ipvar :: { Located HsIPName }
: IPDUPVARID { L1 (HsIPName (getIPDUPVARID $1)) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
......
......@@ -285,6 +285,9 @@ basicKnownKeyNames
typeNatMulTyFamName,
typeNatExpTyFamName,
-- Implicit parameters
ipClassName,
-- Annotation type checking
toAnnotationWrapperName
......@@ -348,7 +351,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
......@@ -402,6 +405,7 @@ rANDOM = mkBaseModule (fsLit "System.Random")
gHC_EXTS = mkBaseModule (fsLit "GHC.Exts")
cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits")
gHC_IP = mkBaseModule (fsLit "GHC.IP")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
......@@ -1081,6 +1085,12 @@ typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey
typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey
typeNatExpTyFamName = tcQual gHC_TYPELITS (fsLit "^") typeNatExpTyFamNameKey
-- Implicit parameters
ipClassName :: Name
ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey
-- dotnet interop
objectTyConName :: Name
objectTyConName = tcQual dOTNET (fsLit "Object") objectTyConKey
......@@ -1201,6 +1211,9 @@ typeNatLeqClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
ipClassNameKey :: Unique
ipClassNameKey = mkPreludeClassUnique 45
\end{code}
%************************************************************************
......
......@@ -72,8 +72,6 @@ module TysWiredIn (
-- * Equality predicates
eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
-- * Implicit parameter predicates
mkIPName
) where
#include "HsVersions.h"
......@@ -85,7 +83,6 @@ import PrelNames
import TysPrim
-- others:
import Coercion
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module )
import Type ( mkTyConApp )
......@@ -95,7 +92,7 @@ import TyCon
import TypeRep
import RdrName
import Name
import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..),
import BasicTypes ( TupleSort(..), tupleSortBoxity,
Arity, RecFlag(..), Boxity(..), HsBang(..) )
import ForeignCall
import Unique ( incrUnique, mkTupleTyConUnique,
......@@ -254,9 +251,6 @@ pcTyCon is_enum is_rec name cType tyvars cons
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
pcDataCon' :: Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon' = pcDataConWithFixity' False
pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n))
-- The Name's unique is the first of two free uniques;
......@@ -395,39 +389,6 @@ unboxedPairDataCon :: DataCon
unboxedPairDataCon = tupleCon UnboxedTuple 2
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-ImplicitParams]{Special type constructors for implicit parameters}
%* *
%************************************************************************
\begin{code}
mkIPName :: FastString
-> Unique -> Unique -> Unique -> Unique
-> IPName Name
mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip
where
name_ip = IPName tycon_name
tycon_name = mkPrimTyConName ip tycon_u tycon
tycon = mkAlgTyCon tycon_name
(liftedTypeKind `mkArrowKind` constraintKind)
[alphaTyVar]
Nothing
[] -- No stupid theta
(NewTyCon { data_con = datacon,
nt_rhs = mkTyVarTy alphaTyVar,
nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar),
nt_co = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) })
(IPTyCon name_ip)
NonRecursive
False
datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon
datacon = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon
co_ax_name = mkPrimTyConName ip co_ax_u tycon
\end{code}
%************************************************************************
%* *
......
......@@ -35,7 +35,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import TcRnMonad
import TcEvidence ( emptyTcEvBinds )
import RnTypes ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch )
import RnPat
import RnEnv
import DynFlags
......@@ -220,10 +220,9 @@ rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
rnIPBind (IPBind n expr) = do
n' <- rnIPName n
rnIPBind (IPBind ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
return (IPBind n' expr', fvExpr)
return (IPBind (Left n) expr', fvExpr)
\end{code}
......
......@@ -111,8 +111,7 @@ rnExpr (HsVar v)
finishHsVar name
rnExpr (HsIPVar v)
= do v' <- rnIPName v
return (HsIPVar v', emptyFVs)
= return (HsIPVar v, emptyFVs)
rnExpr (HsLit lit@(HsString s))
= do {
......
......@@ -16,7 +16,7 @@ module RnTypes (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsMaybeKind,
rnHsSigType, rnLHsInstType, rnConDeclFields,
rnIPName, newTyVarNameRn,
newTyVarNameRn,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
......@@ -41,7 +41,6 @@ import HsSyn
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
import IfaceEnv ( newIPName )
import RdrName
import PrelNames
import TysPrim ( funTyConName )
......@@ -50,7 +49,7 @@ import SrcLoc
import NameSet
import Util
import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity,
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
import Outputable
import FastString
......@@ -248,8 +247,7 @@ rnHsTyKi isType doc (HsAppTy ty1 ty2)
rnHsTyKi isType doc (HsIParamTy n ty)
= ASSERT( isType )
do { (ty', fvs) <- rnLHsType doc ty
; n' <- rnIPName n
; return (HsIParamTy n' ty', fvs) }
; return (HsIParamTy n ty', fvs) }
rnHsTyKi isType doc (HsEqTy ty1 ty2)
= ASSERT( isType )
......@@ -494,9 +492,6 @@ rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVar
rnContext doc (L loc cxt)
= do { (cxt', fvs) <- rnLHsTypes doc cxt
; return (L loc cxt', fvs) }
rnIPName :: IPName RdrName -> RnM (IPName Name)
rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
\end{code}
......
......@@ -519,7 +519,6 @@ hasEqualities givens = any (has_eq . evVarPred) givens
-- See Note [Float Equalities out of Implications] in TcSimplify
has_eq' (EqPred {}) = True
has_eq' (IPPred {}) = False
has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
has_eq' (TuplePred ts) = any has_eq ts
has_eq' (IrredPred _) = True -- Might have equalities in it after reduction?
......@@ -529,7 +528,6 @@ tyVarsOfCt :: Ct -> TcTyVarSet
tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl)
......
......@@ -45,6 +45,9 @@ import Util
import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy)
import Class(classTyCon)
import PrelNames(ipClassName)
import Control.Monad
......@@ -207,7 +210,9 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
= do { ipClass <- tcLookupClass ipClassName
; (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
-- If the binding binds ?x = E, we must now
-- discharge any ?x constraints in expr_lie
......@@ -217,16 +222,28 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
where
ips = [ip | L _ (IPBind ip _) <- ip_binds]
ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds]
-- I wonder if we should do these one at at time
-- Consider ?x = 4
-- ?y = ?x + 1
tc_ip_bind (IPBind ip expr)
tc_ip_bind ipClass (IPBind (Left ip) expr)
= do { ty <- newFlexiTyVarTy openTypeKind
; ip_id <- newIP ip ty
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcMonoExpr expr ty
; return (ip_id, (IPBind (IPName ip_id) expr')) }
; let d = toDict ipClass p ty `fmap` expr'
; return (ip_id, (IPBind (Right ip_id) d)) }
tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
-- Coerces a `t` into a dictionry for `IP "x" t`.