Commit 0f3d8ab9 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 82a8ffd8 1e9a2d34
......@@ -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