import CmdLineOpts ( opt_DictsStrict )
import TysPrim
-import Type ( Type, ThetaType, TauType,
+import Type ( Type, ThetaType, TauType, ClassContext,
mkSigmaTy, mkFunTys, mkTyConApp,
mkTyVarTys, mkDictTy,
- splitAlgTyConApp_maybe
+ splitAlgTyConApp_maybe, classesToPreds
)
import PprType
import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
-- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars and context for the data type decl
- dcTheta :: ThetaType,
+ dcTheta :: ClassContext,
dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
- dcExTheta :: ThetaType, -- the existentially quantified stuff
+ dcExTheta :: ClassContext, -- the existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
+ -> [TyVar] -> ClassContext
+ -> [TyVar] -> ClassContext
-> [TauType] -> TyCon
-> Id
-> DataCon
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkSigmaTy (tyvars ++ ex_tyvars)
- ex_theta
+ (classesToPreds ex_theta)
(mkFunTys rep_arg_tys
(mkTyConApp tycon (mkTyVarTys tyvars)))
| opt_DictsStrict &&
-- Don't mark newtype things as strict!
isDataTyCon (classTyCon clas) = MarkedStrict
- | otherwise = NotMarkedStrict
+ | otherwise = NotMarkedStrict
\end{code}
\begin{code}
go (NotMarkedStrict : ss) = wwLazy : go ss
go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
-dataConSig :: DataCon -> ([TyVar], ThetaType,
- [TyVar], ThetaType,
+dataConSig :: DataCon -> ([TyVar], ClassContext,
+ [TyVar], ClassContext,
[TauType], TyCon)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
import PrelMods ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
-import Type ( Type, ThetaType,
- mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
+import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
+ mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys, unUsgTy,
)
import Module ( Module )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
where
(tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
- (theta ++ ex_theta)
+ (classesToPreds (theta ++ ex_theta))
(mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
\end{code}
-> Class
-> [TyVar]
-> [Type]
- -> ThetaType
+ -> ClassContext
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
= mkVanillaId dfun_name dfun_ty
where
(class_tyvars, sc_theta, _, _) = classBigSig clas
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
- dfun_theta = inst_decl_theta
+ dfun_theta = classesToPreds inst_decl_theta
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
-- The Name type
Name, -- Abstract
mkLocalName, mkImportedLocalName, mkSysLocalName,
- mkTopName,
+ mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
n_occ = mkSrcVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)),
n_prov = LocalDef noSrcLoc NotExported }
+mkIPName :: Unique -> OccName -> Name
+mkIPName uniq occ
+ = Name { n_uniq = uniq,
+ n_sort = Local,
+ n_occ = mkIPOcc occ,
+ n_prov = SystemProv }
+
------------------------- Wired in names -------------------------
mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name
\begin{code}
module OccName (
-- The NameSpace type; abstact
- NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName,
- uvName, nameSpaceString,
+ NameSpace, tcName, clsName, tcClsName, dataName, varName, ipName,
+ tvName, uvName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
mkSrcOccFS, mkSysOcc, mkSysOccFS, mkSrcVarOcc, mkKindOccFS,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
- mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
+ mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc,
+ isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
\begin{code}
data NameSpace = VarName -- Variables
+ | IPName -- Implicit Parameters
| DataName -- Data constructors
| TvName -- Type variables
| UvName -- Usage variables
| TcClsName -- Type constructors and classes; Haskell has them
- -- in the same name space for now.
+ -- in the same name space for now.
deriving( Eq, Ord )
-- Though type constructors and classes are in the same name space now,
tvName = TvName
uvName = UvName
varName = VarName
+ipName = IPName
nameSpaceString :: NameSpace -> String
nameSpaceString DataName = "Data constructor"
nameSpaceString VarName = "Variable"
+nameSpaceString IPName = "Implicit Param"
nameSpaceString TvName = "Type variable"
nameSpaceString UvName = "Usage variable"
nameSpaceString TcClsName = "Type constructor or class"
-- Pretty inefficient!
isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
+
+isIPOcc (OccName IPName _) = True
+isIPOcc _ = False
\end{code}
\end{code}
\begin{code}
-mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
+mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc
:: OccName -> OccName
mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon
mkClassDataConOcc = mk_simple_deriv dataName ":D" --
mkDictOcc = mk_simple_deriv varName "$d"
+mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
- substTy, substTheta,
+ substTy, substClasses, substTheta,
-- Expression stuff
substExpr, substIdInfo
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..),
) -- friend
-import Type ( ThetaType,
+import Type ( ThetaType, PredType(..), ClassContext,
tyVarsOfType, tyVarsOfTypes, mkAppTy
)
import VarSet
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
+substClasses :: TyVarSubst -> ClassContext -> ClassContext
+substClasses subst theta
+ | isEmptySubst subst = theta
+ | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
+
substTheta :: TyVarSubst -> ThetaType -> ThetaType
substTheta subst theta
| isEmptySubst subst = theta
- | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
+ | otherwise = map (substPred subst) theta
+
+substPred :: TyVarSubst -> PredType -> PredType
+substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
subst_ty subst ty
= go ty
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
+ go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
Nothing -> ty
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
dsExpr e@(HsVar var) = returnDs (Var var)
+dsExpr e@(HsIPVar var) = returnDs (Var var)
\end{code}
%************************************************************************
dsExpr (HsLet binds body)
= dsExpr body `thenDs` \ body' ->
dsLet binds body'
-
+
+dsExpr (HsWith expr binds)
+ = dsExpr expr `thenDs` \ expr' ->
+ foldlDs dsIPBind expr' binds
+ where
+ dsIPBind body (n, e)
+ = dsExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec n e') body)
+
dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
| maybeToBool maybe_list_comp
= -- Special case for list comprehensions
\begin{code}
data TyClDecl name pat
= TyData NewOrData
- (Context name) -- context
- name -- type constructor
- [HsTyVar name] -- type variables
- [ConDecl name] -- data constructors (empty if abstract)
- (Maybe [name]) -- derivings; Nothing => not specified
- -- (i.e., derive default); Just [] => derive
- -- *nothing*; Just <list> => as you would
- -- expect...
+ (HsContext name) -- context
+ name -- type constructor
+ [HsTyVar name] -- type variables
+ [ConDecl name] -- data constructors (empty if abstract)
+ (Maybe [name]) -- derivings; Nothing => not specified
+ -- (i.e., derive default); Just [] => derive
+ -- *nothing*; Just <list> => as you would
+ -- expect...
(DataPragmas name)
SrcLoc
(HsType name) -- synonym expansion
SrcLoc
- | ClassDecl (Context name) -- context...
+ | ClassDecl (HsContext name) -- context...
name -- name of the class
[HsTyVar name] -- the class type variables
[([name], [name])] -- functional dependencies
ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
= pp_tydecl
- (pp_decl_head keyword (pprContext context) tycon tyvars)
+ (pp_decl_head keyword (pprHsContext context) tycon tyvars)
(pp_condecls condecls)
derivings
where
ppr methods,
char '}'])]
where
- top_matter = hsep [ptext SLIT("class"), pprContext context,
+ top_matter = hsep [ptext SLIT("class"), pprHsContext context,
ppr clas, hsep (map (ppr) tyvars), pprFundeps fds]
ppr_sig sig = ppr sig <> semi
= ConDecl name -- Constructor name
[HsTyVar name] -- Existentially quantified type variables
- (Context name) -- ...and context
+ (HsContext name) -- ...and context
-- If both are empty then there are no existentials
(ConDetails name)
\begin{code}
instance (Outputable name) => Outputable (ConDecl name) where
ppr (ConDecl con tvs cxt con_details loc)
- = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
+ = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
\begin{code}
data HsExpr id pat
= HsVar id -- variable
+ | HsIPVar id -- implicit parameter
| HsLit HsLit -- literal
| HsLitOut HsLit -- TRANSLATION
Type -- (with its type)
| HsLet (HsBinds id pat) -- let(rec)
(HsExpr id pat)
+ | HsWith (HsExpr id pat) -- implicit parameter binding
+ [(id, HsExpr id pat)]
+
| HsDo StmtCtxt
[Stmt id pat] -- "do":one or more stmts
SrcLoc
pprBinds b = pprDeeper (ppr b)
ppr_expr (HsVar v) = ppr v
+ppr_expr (HsIPVar v) = char '?' <> ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsLitOut lit _) = ppr lit
= sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
+ppr_expr (HsWith expr binds)
+ = hsep [ppr expr, ptext SLIT("with"), ppr binds]
+
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
HsLitOut l _ -> ppr l
HsVar _ -> pp_as_was
+ HsIPVar _ -> pp_as_was
ExplicitList _ -> pp_as_was
ExplicitListOut _ _ -> pp_as_was
ExplicitTuple _ _ -> pp_as_was
\begin{code}
module HsTypes (
HsType(..), MonoUsageAnn(..), HsTyVar(..),
- Context, ClassAssertion
+ HsContext, HsClassAssertion, HsPred(..)
, mkHsForAllTy, mkHsUsForAllTy
, getTyVarName, replaceTyVarName
, pprParendHsType
- , pprForAll, pprContext, pprClassAssertion
- , cmpHsType, cmpHsTypes, cmpContext
+ , pprForAll, pprHsContext, pprHsClassAssertion, pprHsPred
+ , cmpHsType, cmpHsTypes, cmpHsContext, cmpHsPred
) where
#include "HsVersions.h"
This is the syntax for types as seen in type signatures.
\begin{code}
-type Context name = [ClassAssertion name]
-
-type ClassAssertion name = (name, [HsType name])
- -- The type is usually a type variable, but it
- -- doesn't have to be when reading interface files
+type HsContext name = [HsPred name]
+type HsClassAssertion name = (name, [HsType name])
+-- The type is usually a type variable, but it
+-- doesn't have to be when reading interface files
+data HsPred name =
+ HsPClass name [HsType name]
+ | HsPIParam name (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures
- (Context name)
+ (HsContext name)
(HsType name)
| MonoTyVar name -- Type variable
-- pprForAll [] = empty
pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
-pprContext :: (Outputable name) => Context name -> SDoc
-pprContext [] = empty
-pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
+pprHsContext :: (Outputable name) => HsContext name -> SDoc
+pprHsContext [] = empty
+pprHsContext context = parens (hsep (punctuate comma (map pprHsPred context))) <+> ptext SLIT("=>")
+
+pprHsClassAssertion :: (Outputable name) => HsClassAssertion name -> SDoc
+pprHsClassAssertion (clas, tys)
+ = ppr clas <+> hsep (map pprParendHsType tys)
-pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
-pprClassAssertion (clas, tys)
+pprHsPred :: (Outputable name) => HsPred name -> SDoc
+pprHsPred (HsPClass clas tys)
= ppr clas <+> hsep (map pprParendHsType tys)
+pprHsPred (HsPIParam n ty)
+ = hsep [char '?' <> ppr n, text "::", ppr ty]
\end{code}
\begin{code}
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
= maybeParen (ctxt_prec >= pREC_FUN) $
- sep [pp_tvs, pprContext ctxt, pprHsType ty]
+ sep [pp_tvs, pprHsContext ctxt, pprHsType ty]
where
pp_tvs = case maybe_tvs of
Just tvs -> pprForAll tvs
wrong}, so be careful!
\begin{code}
-cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering
-cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering
-cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
-cmpContext :: (a -> a -> Ordering) -> Context a -> Context a -> Ordering
+cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering
+cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering
+cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
+cmpHsContext :: (a -> a -> Ordering) -> HsContext a -> HsContext a -> Ordering
+cmpHsPred :: (a -> a -> Ordering) -> HsPred a -> HsPred a -> Ordering
cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2
cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
cmpHsTyVar cmp (UserTyVar _) other = LT
cmpHsTyVar cmp other1 other2 = GT
-
cmpHsTypes cmp [] [] = EQ
cmpHsTypes cmp [] tys2 = LT
cmpHsTypes cmp tys1 [] = GT
cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
= cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp`
- cmpContext cmp c1 c2 `thenCmp`
+ cmpHsContext cmp c1 c2 `thenCmp`
cmpHsType cmp t1 t2
cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
tag (HsForAllTy _ _ _) = ILIT(9)
-------------------
-cmpContext cmp a b
- = cmpList cmp_ctxt a b
- where
- cmp_ctxt (c1, tys1) (c2, tys2)
- = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+cmpHsContext cmp a b
+ = cmpList (cmpHsPred cmp) a b
+
+cmpHsPred cmp (HsPClass c1 tys1) (HsPClass c2 tys2)
+ = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+cmpHsPred cmp (HsPIParam n1 ty1) (HsPIParam n2 ty2)
+ = cmp n1 n2 `thenCmp` cmpHsType cmp ty1 ty2
+cmpHsPred cmp (HsPClass _ _) (HsPIParam _ _) = LT
+cmpHsPred cmp _ _ = GT
cmpUsg cmp MonoUsOnce MonoUsOnce = EQ
cmpUsg cmp MonoUsMany MonoUsMany = EQ
)
import Class ( Class, classExtraBigSig )
import FieldLabel ( fieldLabelName, fieldLabelType )
-import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
+import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
+ deNoteType, classesToPreds,
Type, ThetaType
)
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
- forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
+ forall_ty = mkSigmaTy tvs (classesToPreds theta)
+ (deNoteType (mkDictTy clas tys))
renumbered_ty = tidyTopType forall_ty
in
hcat [ptext SLIT("instance "), pprType renumbered_ty,
ifaceTyCon tycon
| isAlgTyCon tycon
= hsep [ ptext keyword,
- ppr_decl_context (tyConTheta tycon),
+ ppr_decl_class_context (tyConTheta tycon),
ppr (getName tycon),
pprTyVarBndrs (tyConTyVars tycon),
ptext SLIT("="),
ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
- <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>")
+ <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
ifaceClass clas
= hsep [ptext SLIT("class"),
- ppr_decl_context sc_theta,
+ ppr_decl_class_context sc_theta,
ppr clas, -- Print the name
pprTyVarBndrs clas_tyvars,
pprFundeps clas_fds,
ppr_decl_context [] = empty
ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
+ppr_decl_class_context :: [(Class,[Type])] -> SDoc
+ppr_decl_class_context [] = empty
+ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
+
pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files
pprIfaceTheta [] = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
+pprIfaceTheta theta = braces (hsep (punctuate comma [pprPred p | p <- theta]))
+
+pprIfaceClasses :: [(Class,[Type])] -> SDoc
+pprIfaceClasses [] = empty
+pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
\end{code}
%************************************************************************
| ITlabel
| ITdynamic
| ITunsafe
+ | ITwith
| ITstdcallconv
| ITccallconv
| ITqvarsym (FAST_STRING,FAST_STRING)
| ITqconsym (FAST_STRING,FAST_STRING)
+ | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x
+
| ITpragma StringBuffer
| ITchar Char
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "unsafe", ITunsafe ),
+ ( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
("_ccall_", ITccall (False, False, False)),
trace "lexIface: misplaced NUL?" $
cont (ITunknown "\NUL") (stepOn buf)
+ '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+ lex_ip cont (setCurrentPos# buf 1#)
c | is_digit c -> lex_num cont glaexts 0 buf
| is_symbol c -> lex_sym cont buf
| is_upper c -> lex_con cont glaexts buf
is_symbol = is_ctype 2
is_any = is_ctype 4
is_space = is_ctype 8
-is_upper = is_ctype 16
-is_digit = is_ctype 32
+is_lower = is_ctype 16
+is_upper = is_ctype 32
+is_digit = is_ctype 64
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
+lex_ip cont buf =
+ case expandWhile# is_ident buf of
+ buf' -> cont (ITipvarid lexeme) buf'
+ where lexeme = lexemeToFastString buf'
+
lex_id cont glaexts buf =
case expandWhile# is_ident buf of { buf1 ->
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (MonoTupleTy ts True)
= mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
- returnP cs
+ returnP (map (uncurry HsPClass) cs)
checkContext (MonoTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
- = checkAssertion t [] `thenP` \c ->
- returnP [c]
+ = checkAssertion t [] `thenP` \(c,ts) ->
+ returnP [HsPClass c ts]
checkAssertion :: RdrNameHsType -> [RdrNameHsType]
- -> P (ClassAssertion RdrName)
+ -> P (HsClassAssertion RdrName)
checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (t,args)
checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
checkExpr e = case e of
HsVar _ -> returnP e
+ HsIPVar _ -> returnP e
HsLit _ -> returnP e
HsLam match -> checkMatch match `thenP` (returnP.HsLam)
HsApp e1 e2 -> check2Exprs e1 e2 HsApp
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.18 1999/12/01 17:01:36 simonmar Exp $
+$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $
Haskell grammar.
import ParseUtil
import RdrName
import PrelMods ( mAIN_Name )
-import OccName ( varName, dataName, tcClsName, tvName )
+import OccName ( varName, ipName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
import CallConv
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
+ 'with' { ITwith }
'_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ IPVARID { ITipvarid $$ }
PRAGMA { ITpragma $$ }
exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 }
+ | infixexp 'with' dbinding { HsWith $1 $3 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
aexp1 :: { RdrNameHsExpr }
: qvar { HsVar $1 }
+ | IPVARID { HsIPVar (mkSrcUnqual ipName $1) }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
: qvar '=' exp { ($1,$3,False) }
-----------------------------------------------------------------------------
+-- Implicit Parameter Bindings
+
+dbinding :: { [(RdrName, RdrNameHsExpr)] }
+ : '{' dbinds '}' { $2 }
+ | layout_on dbinds close { $2 }
+
+dbinds :: { [(RdrName, RdrNameHsExpr)] }
+ : dbinds ';' dbind { $3 : $1 }
+ | dbinds ';' { $1 }
+ | dbind { [$1] }
+ | {- empty -} { [] }
+
+dbind :: { (RdrName, RdrNameHsExpr) }
+dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) }
+
+-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
gcon :: { RdrName }
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameConDetails = ConDetails RdrName
-type RdrNameContext = Context RdrName
+type RdrNameContext = HsContext RdrName
type RdrNameHsDecl = HsDecl RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
go (RuleBndr _) acc = acc
go (RuleBndrSig _ ty) acc = extract_ty ty acc
-extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
+extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
-extract_ctxt ctxt acc = foldr extract_ass acc ctxt
- where
- extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
+extract_ctxt ctxt acc = foldr extract_pred acc ctxt
+
+extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_pred (HsPIParam n ty) acc = extract_ty ty acc
extract_tys tys acc = foldr extract_ty acc tys
C_Any | C_Symbol, /* \ */
C_Any, /* ] */
C_Any | C_Symbol, /* ^ */
- C_Any | C_Ident, /* _ */
+ C_Any | C_Ident | C_Lower, /* _ */
C_Any, /* ` */
- C_Any | C_Ident, /* a */
- C_Any | C_Ident, /* b */
- C_Any | C_Ident, /* c */
- C_Any | C_Ident, /* d */
- C_Any | C_Ident, /* e */
- C_Any | C_Ident, /* f */
- C_Any | C_Ident, /* g */
- C_Any | C_Ident, /* h */
- C_Any | C_Ident, /* i */
- C_Any | C_Ident, /* j */
- C_Any | C_Ident, /* k */
- C_Any | C_Ident, /* l */
- C_Any | C_Ident, /* m */
- C_Any | C_Ident, /* n */
- C_Any | C_Ident, /* o */
- C_Any | C_Ident, /* p */
- C_Any | C_Ident, /* q */
- C_Any | C_Ident, /* r */
- C_Any | C_Ident, /* s */
- C_Any | C_Ident, /* t */
- C_Any | C_Ident, /* u */
- C_Any | C_Ident, /* v */
- C_Any | C_Ident, /* w */
- C_Any | C_Ident, /* x */
- C_Any | C_Ident, /* y */
- C_Any | C_Ident, /* z */
+ C_Any | C_Ident | C_Lower, /* a */
+ C_Any | C_Ident | C_Lower, /* b */
+ C_Any | C_Ident | C_Lower, /* c */
+ C_Any | C_Ident | C_Lower, /* d */
+ C_Any | C_Ident | C_Lower, /* e */
+ C_Any | C_Ident | C_Lower, /* f */
+ C_Any | C_Ident | C_Lower, /* g */
+ C_Any | C_Ident | C_Lower, /* h */
+ C_Any | C_Ident | C_Lower, /* i */
+ C_Any | C_Ident | C_Lower, /* j */
+ C_Any | C_Ident | C_Lower, /* k */
+ C_Any | C_Ident | C_Lower, /* l */
+ C_Any | C_Ident | C_Lower, /* m */
+ C_Any | C_Ident | C_Lower, /* n */
+ C_Any | C_Ident | C_Lower, /* o */
+ C_Any | C_Ident | C_Lower, /* p */
+ C_Any | C_Ident | C_Lower, /* q */
+ C_Any | C_Ident | C_Lower, /* r */
+ C_Any | C_Ident | C_Lower, /* s */
+ C_Any | C_Ident | C_Lower, /* t */
+ C_Any | C_Ident | C_Lower, /* u */
+ C_Any | C_Ident | C_Lower, /* v */
+ C_Any | C_Ident | C_Lower, /* w */
+ C_Any | C_Ident | C_Lower, /* x */
+ C_Any | C_Ident | C_Lower, /* y */
+ C_Any | C_Ident | C_Lower, /* z */
C_Any, /* { */
C_Any | C_Symbol, /* | */
C_Any, /* } */
C_Any | C_Ident | C_Upper, /* Ô */
C_Any | C_Ident | C_Upper, /* Õ */
C_Any | C_Ident | C_Upper, /* Ö */
- C_Any | C_Symbol, /* × */
+ C_Any | C_Symbol | C_Lower, /* × */
C_Any | C_Ident | C_Upper, /* Ø */
C_Any | C_Ident | C_Upper, /* Ù */
C_Any | C_Ident | C_Upper, /* Ú */
C_Any | C_Ident | C_Upper, /* Ý */
C_Any | C_Ident | C_Upper, /* Þ */
C_Any | C_Ident, /* ß */
- C_Any | C_Ident, /* à */
- C_Any | C_Ident, /* á */
- C_Any | C_Ident, /* â */
- C_Any | C_Ident, /* ã */
- C_Any | C_Ident, /* ä */
- C_Any | C_Ident, /* å */
- C_Any | C_Ident, /* æ */
- C_Any | C_Ident, /* ç */
- C_Any | C_Ident, /* è */
- C_Any | C_Ident, /* é */
- C_Any | C_Ident, /* ê */
- C_Any | C_Ident, /* ë */
- C_Any | C_Ident, /* ì */
- C_Any | C_Ident, /* í */
- C_Any | C_Ident, /* î */
- C_Any | C_Ident, /* ï */
- C_Any | C_Ident, /* ð */
- C_Any | C_Ident, /* ñ */
- C_Any | C_Ident, /* ò */
- C_Any | C_Ident, /* ó */
- C_Any | C_Ident, /* ô */
- C_Any | C_Ident, /* õ */
- C_Any | C_Ident, /* ö */
+ C_Any | C_Ident | C_Lower, /* à */
+ C_Any | C_Ident | C_Lower, /* á */
+ C_Any | C_Ident | C_Lower, /* â */
+ C_Any | C_Ident | C_Lower, /* ã */
+ C_Any | C_Ident | C_Lower, /* ä */
+ C_Any | C_Ident | C_Lower, /* å */
+ C_Any | C_Ident | C_Lower, /* æ */
+ C_Any | C_Ident | C_Lower, /* ç */
+ C_Any | C_Ident | C_Lower, /* è */
+ C_Any | C_Ident | C_Lower, /* é */
+ C_Any | C_Ident | C_Lower, /* ê */
+ C_Any | C_Ident | C_Lower, /* ë */
+ C_Any | C_Ident | C_Lower, /* ì */
+ C_Any | C_Ident | C_Lower, /* í */
+ C_Any | C_Ident | C_Lower, /* î */
+ C_Any | C_Ident | C_Lower, /* ï */
+ C_Any | C_Ident | C_Lower, /* ð */
+ C_Any | C_Ident | C_Lower, /* ñ */
+ C_Any | C_Ident | C_Lower, /* ò */
+ C_Any | C_Ident | C_Lower, /* ó */
+ C_Any | C_Ident | C_Lower, /* ô */
+ C_Any | C_Ident | C_Lower, /* õ */
+ C_Any | C_Ident | C_Lower, /* ö */
C_Any | C_Symbol, /* ÷ */
C_Any | C_Ident, /* ø */
- C_Any | C_Ident, /* ù */
- C_Any | C_Ident, /* ú */
- C_Any | C_Ident, /* û */
- C_Any | C_Ident, /* ü */
- C_Any | C_Ident, /* ý */
- C_Any | C_Ident, /* þ */
- C_Any | C_Ident, /* ÿ */
+ C_Any | C_Ident | C_Lower, /* ù */
+ C_Any | C_Ident | C_Lower, /* ú */
+ C_Any | C_Ident | C_Lower, /* û */
+ C_Any | C_Ident | C_Lower, /* ü */
+ C_Any | C_Ident | C_Lower, /* ý */
+ C_Any | C_Ident | C_Lower, /* þ */
+ C_Any | C_Ident | C_Lower, /* ÿ */
};
#define C_Symbol 1<<1
#define C_Any 1<<2
#define C_Space 1<<3
-#define C_Upper 1<<4
-#define C_Digit 1<<5
+#define C_Lower 1<<4
+#define C_Upper 1<<5
+#define C_Digit 1<<6
#define _IsType(c,flags) (char_types[(int)(c)] & flags)
#define IsIdent(c) (_IsType(c,C_Ident))
#define IsAny(c) (_IsType(c,C_Any))
#define IsSymbol(c) (_IsType(c,C_Symbol))
+#define IsLower(c) (_IsType(c,C_Lower))
#define IsUpper(c) (_IsType(c,C_Upper))
#define IsDigit(c) (_IsType(c,C_Digit))
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys, isUnLiftedType,
splitTyConApp_maybe, splitAlgTyConApp_maybe,
- ThetaType, TauType )
+ TauType, ClassContext )
import PrimRep ( PrimRep(..) )
import Unique
import CmdLineOpts ( opt_GlasgowExts )
name = mkWiredInTyConName key mod str tycon
pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon
+ -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon
pcDataCon key mod str tyvars context arg_tys tycon
= data_con
where
import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
import Name ( OccName, Provenance )
import OccName ( mkSysOccFS,
- tcName, varName, dataName, clsName, tvName, uvName,
+ tcName, varName, ipName, dataName, clsName, tvName, uvName,
EncodedFS
)
import Module ( ModuleName, mkSysModuleFS )
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ IPVARID { ITipvarid $$ }
PRAGMA { ITpragma $$ }
context_list1 : class { [$1] }
| class ',' context_list1 { $1 : $3 }
-class :: { (RdrName, [RdrNameHsType]) }
-class : qcls_name atypes { ($1, $2) }
+class :: { HsPred RdrName }
+class : qcls_name atypes { (HsPClass $1 $2) }
+ | IPVARID '::' type { (HsPIParam (mkSysUnqual ipName $1) $3) }
types0 :: { [RdrNameHsType] {- Zero or more -} }
types0 : {- empty -} { [ ] }
import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
- mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
+ mkLocalName, mkImportedLocalName, mkGlobalName,
+ mkIPName, isSystemName,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
occNameUserString,
\begin{code}
newImportedGlobalName mod_name occ mod
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
let
key = (mod_name, occ)
in
case lookupFM cache key of
Just name -> returnRn name
- Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
+ Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply us
updateProvenances :: [Name] -> RnM d ()
updateProvenances names
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
- setNameSupplyRn (us, inst_ns, update cache names)
+ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+ setNameSupplyRn (us, inst_ns, update cache names, ipcache)
where
update cache [] = cache
update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
-> RnM d Name
newLocalTopBinder mod occ rec_exp_fn loc
= -- First check the cache
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
let
key = (moduleName mod,occ)
mk_prov name = LocalDef loc (rec_exp_fn name)
new_name = setNameProvenance name (mk_prov new_name)
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us, inst_ns, new_cache) `thenRn_`
+ setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_`
returnRn new_name
-- Miss in the cache!
new_name = mkGlobalName uniq mod occ (mk_prov new_name)
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
+ setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
returnRn new_name
+
+getIPName rdr_name
+ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+ case lookupFM ipcache key of
+ Just name -> returnRn name
+ Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_`
+ returnRn name
+ where
+ (us', us1) = splitUniqSupply us
+ uniq = uniqFromSupply us1
+ name = mkIPName uniq key
+ new_ipcache = addToFM ipcache key name
+ where key = (rdrNameOcc rdr_name)
\end{code}
%*********************************************************
returnRn ()
) `thenRn_`
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
getModeRn `thenRn` \ mode ->
let
n = length rdr_names_w_loc
-- Keep track of whether the name originally came from
-- an interface file.
in
- setNameSupplyRn (us', inst_ns, cache) `thenRn_`
+ setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
let
new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
bindCoreLocalFVRn rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
getLocalNameEnv `thenRn` \ name_env ->
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
in
- setNameSupplyRn (us', inst_ns, cache) `thenRn_`
+ setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
let
new_name_env = extendRdrEnv name_env rdr_name name
in
-- The normal case
returnRn (HsVar name, unitFV name)
+rnExpr (HsIPVar v)
+ = getIPName v `thenRn` \ name ->
+ returnRn (HsIPVar name, emptyFVs)
+
rnExpr (HsLit lit)
= litOccurrence lit `thenRn` \ fvs ->
returnRn (HsLit lit, fvs)
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
+rnExpr (HsWith expr binds)
+ = rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
+
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
%************************************************************************
%* *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
+%* *
+%************************************************************************
+
+\begin{code}
+rnIPBinds [] = returnRn ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+ = getIPName n `thenRn` \ name ->
+ rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection{@Stmt@s: in @do@ expressions}
%* *
%************************************************************************
type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat
type RenamedClassOpSig = Sig Name
type RenamedConDecl = ConDecl Name
-type RenamedContext = Context Name
+type RenamedContext = HsContext Name
type RenamedHsDecl = HsDecl Name RenamedPat
type RenamedRuleDecl = RuleDecl Name RenamedPat
type RenamedTyClDecl = TyClDecl Name RenamedPat
extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
extractHsCtxtTyNames :: RenamedContext -> NameSet
-extractHsCtxtTyNames ctxt = foldr (unionNameSets . get) emptyNameSet ctxt
- where
- get (cls, tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
+extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt
+
+-- You don't import or export implicit parameters, so don't mention
+-- the IP names
+extractHsPredTyNames (HsPClass cls tys)
+ = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
+extractHsPredTyNames (HsPIParam n ty)
+ = extractHsTyNames ty
\end{code}
, FiniteMap (ModuleName, OccName) Name
-- Ensures that one (module,occname) pair gets one unique
+ , FiniteMap OccName Name
+ -- Ensures that one implicit parameter name gets one unique
)
initRn mod us dirs loc do_rn = do
himaps <- mkModuleHiMaps dirs
- names_var <- newIORef (us, emptyFM, builtins)
+ names_var <- newIORef (us, emptyFM, builtins, emptyFM)
errs_var <- newIORef (emptyBag,emptyBag)
iface_var <- newIORef emptyIfaces
let
-- See comments with RnNameSupply above.
newInstUniq :: String -> RnM d Int
newInstUniq key (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache) ->
+ = readIORef names_var >>= \ (us, mapInst, cache, ipcache) ->
let
uniq = case lookupFM mapInst key of
Just x -> x+1
Nothing -> 0
mapInst' = addToFM mapInst key uniq
in
- writeIORef names_var (us, mapInst', cache) >>
+ writeIORef names_var (us, mapInst', cache, ipcache) >>
return uniq
getUniqRn :: RnM d Unique
getUniqRn (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache) ->
+ = readIORef names_var >>= \ (us, mapInst, cache, ipcache) ->
let
(us1,us') = splitUniqSupply us
in
- writeIORef names_var (us', mapInst, cache) >>
+ writeIORef names_var (us', mapInst, cache, ipcache) >>
return (uniqFromSupply us1)
\end{code}
import RnExpr
import HsSyn
import HsPragmas
-import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes )
+import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
-import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
+import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
lookupImplicitOccRn,
bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
-- context in which case it's an error
= let
mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
- ty <- tys,
+ mentioned_in_ctxt = nub [tv | p <- ctxt,
+ ty <- tys_of_pred p,
tv <- extractHsTyRdrTyVars ty]
+ tys_of_pred (HsPClass clas tys) = tys
+ tys_of_pred (HsPIParam n ty) = [ty]
dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-- dubious = explicitly quantified but not mentioned in tau type
-- of the tau-type part, this guarantees that every constraint mentions
-- at least one of the free tyvars in ty
checkConstraints doc forall_tyvars tau_vars ctxt ty
- = mapRn check ctxt `thenRn` \ maybe_ctxt' ->
+ = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
returnRn (catMaybes maybe_ctxt')
-- Remove problem ones, to avoid duplicate error message.
- where
- check ct@(_,tys)
- | not_univ = failWithRn Nothing (univErr doc ct ty)
- | otherwise = returnRn (Just ct)
- where
- ct_vars = extractHsTysRdrTyVars tys
-
- not_univ = -- At least one of the tyvars in each constraint must
- -- be universally quantified. This restriction isn't in Hugs
- not (any (`elem` forall_tyvars) ct_vars)
+checkPred doc forall_tyvars ty p@(HsPClass clas tys)
+ | not_univ = failWithRn Nothing (univErr doc p ty)
+ | otherwise = returnRn (Just p)
+ where
+ ct_vars = extractHsTysRdrTyVars tys
+ not_univ = -- At least one of the tyvars in each constraint must
+ -- be universally quantified. This restriction isn't in Hugs
+ not (any (`elem` forall_tyvars) ct_vars)
+checkPred doc forall_tyvars ty p@(HsPIParam _ _)
+ = returnRn (Just p)
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
rnContext doc ctxt
- = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) ->
+ = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
let
- (_, dup_asserts) = removeDups cmp_assert theta
+ (_, dup_asserts) = removeDups (cmpHsPred compare) theta
in
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
returnRn (theta, plusFVs fvs_s)
- where
- rn_ctxt (clas, tys)
- = lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
- cmp_assert (c1,tys1) (c2,tys2)
- = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+rnPred doc (HsPClass clas tys)
+ = lookupOccRn clas `thenRn` \ clas_name ->
+ rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
+ returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+rnPred doc (HsPIParam n ty)
+ = getIPName n `thenRn` \ name ->
+ rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (HsPIParam name ty', fvs)
\end{code}
\begin{code}
dupClassAssertWarn ctxt (assertion : dups)
= sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (pprClassAssertion assertion),
+ quotes (pprHsPred assertion),
ptext SLIT("in the context:")],
- nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
+ nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
univErr doc constraint ty
= sep [ptext SLIT("All of the type variable(s) in the constraint")
- <+> quotes (pprClassAssertion constraint)
+ <+> quotes (pprHsPred constraint)
<+> ptext SLIT("are already in scope"),
nest 4 (ptext SLIT("At least one must be universally quantified here"))
]
(ptext SLIT("In") <+> doc)
ambigErr doc constraint ty
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
+ = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
nest 4 (ptext SLIT("in the type:") <+> ppr ty),
nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
$$
import VarEnv
import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
- tyVarsOfType, tyVarsOfTypes, applyTys,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
mkForAllTys, boxedTypeKind
)
import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList,
}
where
(tyvars, theta, tau) = splitSigmaTy (idType f)
- constrained_tyvars = foldr (unionVarSet . tyVarsOfTypes . snd) emptyVarSet theta
+ constrained_tyvars = tyVarsOfTheta theta
n_tyvars = length tyvars
n_dicts = length theta
\begin{code}
module Inst (
LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
- plusLIEs, mkLIE, isEmptyLIE,
+ plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
Inst, OverloadedLit(..),
pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
InstanceMapper,
- newDictFromOld, newDicts, newDictsAtLoc,
- newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
+ newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
+ newMethod, newMethodWithGivenTy, newOverloadedLit,
+ newIPDict, instOverloadedFun,
- tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE,
+ tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
+ getFunDeps, getFunDepsOfLIE,
+ getIPs, getIPsOfLIE,
+ getAllFunDeps, getAllFunDepsOfLIE,
+ partitionLIEbyMeth,
lookupInst, lookupSimpleInst, LookupInstResult(..),
import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
-import PprType ( pprConstraint )
+import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
+import PprType ( pprPred )
import InstEnv ( InstEnv, lookupInstEnv )
import SrcLoc ( SrcLoc )
-import Type ( Type, ThetaType,
- mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
- splitRhoTy, tyVarsOfType, tyVarsOfTypes,
+import Type ( Type, PredType(..), ThetaType,
+ mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
+ splitForAllTys, splitSigmaTy,
+ splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
mkSynTy, tidyOpenType, tidyOpenTypes
)
import InstEnv ( InstEnv )
import Subst ( emptyInScopeSet, mkSubst,
- substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
+ substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
)
import TyCon ( TyCon )
import Var ( TyVar )
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
import Maybes ( expectJust )
+import List ( partition )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
plusLIE lie1 lie2 = lie1 `unionBags` lie2
consLIE inst lie = inst `consBag` lie
plusLIEs lies = unionManyBags lies
+lieToList = bagToList
+listToLIE = listToBag
zonkLIE :: LIE -> NF_TcM s LIE
zonkLIE lie = mapBagNF_Tc zonkInst lie
data Inst
= Dict
Unique
- Class -- The type of the dict is (c ts), where
- [TcType] -- c is the class and ts the types;
+ TcPredType
InstLoc
| Method
\begin{code}
instance Ord Inst where
compare = cmpInst
+instance Ord PredType where
+ compare = cmpPred
instance Eq Inst where
(==) i1 i2 = case i1 `cmpInst` i2 of
EQ -> True
other -> False
+instance Eq PredType where
+ (==) p1 p2 = case p1 `cmpPred` p2 of
+ EQ -> True
+ other -> False
-cmpInst (Dict _ clas1 tys1 _) (Dict _ clas2 tys2 _)
- = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
-cmpInst (Dict _ _ _ _) other
+cmpInst (Dict _ pred1 _) (Dict _ pred2 _)
+ = (pred1 `cmpPred` pred2)
+cmpInst (Dict _ _ _) other
= LT
-
-cmpInst (Method _ _ _ _ _ _) (Dict _ _ _ _)
+cmpInst (Method _ _ _ _ _ _) (Dict _ _ _)
= GT
cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
= (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
cmpInst (FunDep _ _ _) other
= GT
+cmpPred (Class c1 tys1) (Class c2 tys2)
+ = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2)
+cmpPred (IParam n1 ty1) (IParam n2 ty2)
+ = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2)
+cmpPred (Class _ _) (IParam _ _) = LT
+cmpPred _ _ = GT
+
cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT
Selection
~~~~~~~~~
\begin{code}
-instLoc (Dict u clas tys loc) = loc
+instLoc (Dict u pred loc) = loc
instLoc (Method u _ _ _ _ loc) = loc
instLoc (LitInst u lit ty loc) = loc
instLoc (FunDep _ _ loc) = loc
-getDictClassTys (Dict u clas tys _) = (clas, tys)
+getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
getFunDeps (FunDep clas fds _) = Just (clas, fds)
getFunDeps _ = Nothing
-getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie))
+getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
+
+getIPsOfPred (IParam n ty) = [(n, ty)]
+getIPsOfPred _ = []
+getIPsOfTheta theta = concatMap getIPsOfPred theta
+
+getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
+getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
+getIPs _ = []
+
+getIPsOfLIE lie = concatMap getIPs (lieToList lie)
+
+getAllFunDeps (FunDep clas fds _) = fds
+getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
+
+getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
+
+partitionLIEbyMeth pred lie
+ = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
+ where insts = lieToList lie
+
+partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
+ = if null ips_ then
+ returnTc (ips, consLIE m lie)
+ else if null theta_ then
+ returnTc (consLIE m ips, lie)
+ else
+ newMethodWith id tys theta_ tau loc `thenTc` \ new_m2 ->
+ let id_m1 = instToIdBndr new_m2
+ new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
+ -- newMethodWith id_m1 tys ips_ tau loc `thenTc` \ new_m1 ->
+ returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
+ where (ips_, theta_) = partition pred theta
tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (Dict _ _ tys _) = tyVarsOfTypes tys
+tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (FunDep _ fds _)
= foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
where tyVarsOfFd (ts1, ts2) =
- tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts1
+ tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
+
+tyVarsOfInsts insts
+ = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
+
+tyVarsOfLIE lie
+ = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
+ where insts = lieToList lie
\end{code}
Predicates
~~~~~~~~~~
\begin{code}
isDict :: Inst -> Bool
-isDict (Dict _ _ _ _) = True
+isDict (Dict _ (Class _ _) _) = True
isDict other = False
isMethodFor :: TcIdSet -> Inst -> Bool
= False
isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict _ _ tys _) = all isTyVarTy tys
-isTyVarDict other = False
+isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
+isTyVarDict other = False
-isStdClassTyVarDict (Dict _ clas [ty] _) = isStandardClass clas && isTyVarTy ty
-isStdClassTyVarDict other = False
+isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
+ = isStandardClass clas && isTyVarTy ty
+isStdClassTyVarDict other
+ = False
notFunDep :: Inst -> Bool
notFunDep (FunDep _ _ _) = False
\begin{code}
instBindingRequired :: Inst -> Bool
-instBindingRequired (Dict _ clas _ _) = not (isNoDictClass clas)
-instBindingRequired other = True
+instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
+instBindingRequired (Dict _ (IParam _ _) _) = False
+instBindingRequired other = True
instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised (Dict _ clas _ _) = not (isCcallishClass clas)
-instCanBeGeneralised other = True
+instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
+instCanBeGeneralised other = True
\end{code}
newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
returnNF_Tc (listToBag dicts, ids)
+newClassDicts :: InstOrigin
+ -> [(Class,[TcType])]
+ -> NF_TcM s (LIE, [TcId])
+newClassDicts orig theta
+ = newDicts orig (map (uncurry Class) theta)
+
-- Local function, similar to newDicts,
-- but with slightly different interface
newDictsAtLoc :: InstLoc
newDictsAtLoc loc theta =
tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
let
- mk_dict u (clas, tys) = Dict u clas tys loc
+ mk_dict u pred = Dict u pred loc
dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
in
returnNF_Tc (dicts, map instToId dicts)
newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
-newDictFromOld (Dict _ _ _ loc) clas tys
+newDictFromOld (Dict _ _ loc) clas tys
= tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (Dict uniq clas tys loc)
+ returnNF_Tc (Dict uniq (Class clas tys) loc)
newMethod :: InstOrigin
= newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
instFunDeps orig theta `thenNF_Tc` \ fds ->
returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
- --returnNF_Tc (HsVar (instToId inst), unitLIE inst)
instFunDeps orig theta
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
- let ifd (clas, tys) =
+ let ifd (Class clas tys) =
let fds = instantiateFdClassTys clas tys in
if null fds then Nothing else Just (FunDep clas fds loc)
+ ifd _ = Nothing
in returnNF_Tc (catMaybes (map ifd theta))
newMethodWithGivenTy orig id tys theta tau
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ new_uniq ->
- let
- meth_inst = Method new_uniq id tys theta tau loc
- in
- returnNF_Tc meth_inst
+ newMethodWith id tys theta tau loc
+
+newMethodWith id tys theta tau loc
+ = tcGetUnique `thenNF_Tc` \ new_uniq ->
+ returnNF_Tc (Method new_uniq id tys theta tau loc)
newMethodAtLoc :: InstLoc
-> Id -> [TcType]
returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
\end{code}
+\begin{code}
+newIPDict name ty loc
+ = tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let d = Dict new_uniq (IParam name ty) loc in
+ returnNF_Tc d
+\end{code}
\begin{code}
instToId :: Inst -> TcId
instToId inst = instToIdBndr inst
instToIdBndr :: Inst -> TcId
-instToIdBndr (Dict u clas ty (_,loc,_))
+instToIdBndr (Dict u (Class clas ty) (_,loc,_))
= mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
+instToIdBndr (Dict u (IParam n ty) (_,loc,_))
+-- = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc
+ = mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc
+-- = mkVanillaId n ty
instToIdBndr (Method u id tys theta tau (_,loc,_))
= mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
-
+
instToIdBndr (LitInst u list ty loc)
= mkSysLocal SLIT("lit") u ty
need, and it's a lot of extra work.
\begin{code}
+zonkPred :: TcPredType -> NF_TcM s TcPredType
+zonkPred (Class clas tys)
+ = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
+ returnNF_Tc (Class clas new_tys)
+zonkPred (IParam n ty)
+ = zonkTcType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (IParam n new_ty)
+
zonkInst :: Inst -> NF_TcM s Inst
-zonkInst (Dict u clas tys loc)
- = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
- returnNF_Tc (Dict u clas new_tys loc)
+zonkInst (Dict u pred loc)
+ = zonkPred pred `thenNF_Tc` \ new_pred ->
+ returnNF_Tc (Dict u new_pred loc)
zonkInst (Method u id tys theta tau loc)
= zonkId id `thenNF_Tc` \ new_id ->
ppr ty,
show_uniq u]
-pprInst (Dict u clas tys loc) = pprConstraint clas tys <+> show_uniq u
+pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
pprInst (Method u id tys _ _ loc)
= hsep [ppr id, ptext SLIT("at"),
pprInst (FunDep clas fds loc)
= hsep [ppr clas, ppr fds]
+tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
+tidyPred env (Class clas tys)
+ = (env', Class clas tys')
+ where
+ (env', tys') = tidyOpenTypes env tys
+tidyPred env (IParam n ty)
+ = (env', IParam n ty')
+ where
+ (env', ty') = tidyOpenType env ty
+
tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
tidyInst env (LitInst u lit ty loc)
= (env', LitInst u lit ty' loc)
where
(env', ty') = tidyOpenType env ty
-tidyInst env (Dict u clas tys loc)
- = (env', Dict u clas tys' loc)
+tidyInst env (Dict u pred loc)
+ = (env', Dict u pred' loc)
where
- (env', tys') = tidyOpenTypes env tys
+ (env', pred') = tidyPred env pred
tidyInst env (Method u id tys theta tau loc)
= (env', Method u id tys' theta tau loc)
-- Dictionaries
-lookupInst dict@(Dict _ clas tys loc)
+lookupInst dict@(Dict _ (Class clas tys) loc)
= case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
Just (tenv, dfun_id)
rhs = mkHsDictApp ty_app dict_ids
in
returnNF_Tc (GenInst dicts rhs)
-
+
Nothing -> returnNF_Tc NoInstance
+lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
-- Methods
doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
double_lit = HsCon doubleDataCon [] [doubleprim_lit]
--- there are no `instances' of functional dependencies
+-- there are no `instances' of functional dependencies or implicit params
-lookupInst (FunDep _ _ _) = returnNF_Tc NoInstance
+lookupInst _ = returnNF_Tc NoInstance
\end{code}
\begin{code}
lookupSimpleInst :: InstEnv
-> Class
- -> [Type] -- Look up (c,t)
- -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
+ -> [Type] -- Look up (c,t)
+ -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys
= case lookupInstEnv (ppr clas) class_inst_env tys of
Nothing -> returnNF_Tc Nothing
Just (tenv, dfun)
- -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
+ -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
where
(_, theta, _) = splitSigmaTy (idType dfun)
+ theta' = map (\(Class clas tys) -> (clas,tys)) theta
\end{code}
import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
- newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
- zonkFunDeps
+ newDicts, tyVarsOfInst, instToId,
+ getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
import Id ( Id, mkVanillaId, setInlinePragma )
import Var ( idType, idName )
-import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import IdInfo ( setInlinePragInfo, InlinePragInfo(..) )
import Name ( Name, getName, getOccName, getSrcLoc )
import NameSet
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
- mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
+ mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType,
isUnboxedType, unboxedTypeKind, boxedTypeKind
)
import FunDeps ( tyVarFunDep, oclose )
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
- if null real_tyvars_to_gen_list then
- -- No polymorphism, so no need to simplify context
+ let ips = getIPsOfLIE lie_req in
+ if null real_tyvars_to_gen_list && null ips then
+ -- No polymorphism, and no IPs, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
case maybe_sig_theta of
-- NB: no signatures => no polymorphic recursion, so no
-- need to use lie_avail (which will be empty anyway)
tcSimplify (text "tcBinds1" <+> ppr binder_names)
- top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+ real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
Just (sig_theta, lie_avail) ->
-- BUILD RESULTS
returnTc (
+ -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
in
if is_unrestricted
then
- let fds = concatMap snd (getFunDepsOfLIE lie) in
+ let fds = getAllFunDepsOfLIE lie in
zonkFunDeps fds `thenNF_Tc` \ fds' ->
let tvFundep = tyVarFunDep fds'
extended_tyvars = oclose tvFundep body_tyvars in
recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $
discardErrsTc $
- tcSimplify (text "getTVG") NotTopLevel body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
+ tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
= tcAddSrcLoc src_loc $
checkTc (null theta) (mainContextsErr id)
- mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+ mk_dict_tys theta = map mkPredTy theta
sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSs(..),
- HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
- unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
+ HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+ pprHsClassAssertion, unguardedRHS,
+ andMonoBinds, andMonoBindList, getTyVarName,
isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
import NameSet ( emptyNameSet )
import Outputable
-import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
- mkSigmaTy, mkForAllTys, Type, ThetaType,
+import Type ( Type, ThetaType, ClassContext,
+ mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+ mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
boxedTypeKind, mkArrowKind
)
import Var ( tyVarKind, TyVar )
tcClassContext :: Name -> Class -> [TyVar]
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
- -> TcM s (ThetaType, -- the superclass context
+ -> TcM s (ClassContext, -- the superclass context
[Type], -- types of the superclass dictionaries
[Id]) -- superclass selector Ids
tcContext context `thenTc` \ sc_theta ->
let
- sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
+ sc_theta' = classesOfPreds sc_theta
+ sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
in
-- Done
- returnTc (sc_theta, sc_tys, sc_sel_ids)
+ returnTc (sc_theta', sc_tys, sc_sel_ids)
where
rec_tyvar_tys = mkTyVarTys rec_tyvars
ty = mkForAllTys rec_tyvars $
mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
- check_constraint (c, tys) = checkTc (all is_tyvar tys)
- (superClassErr class_name (c, tys))
+ check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
+ (superClassErr class_name (c, tys))
is_tyvar (MonoTyVar _) = True
is_tyvar other = False
tcHsTopType op_ty `thenTc` \ local_ty ->
let
global_ty = mkSigmaTy rec_clas_tyvars
- [(rec_clas, mkTyVarTys rec_clas_tyvars)]
+ [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
local_ty
-- Build the selector id and default method id
tc_dm op_item@(_, dm_id, _)
= tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
let
- theta = [(clas,inst_tys)]
+ theta = [(mkClassPred clas inst_tys)]
in
newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
let
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
superClassErr class_name sc
- = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
+ = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
defltMethCtxt class_name
)
import Type ( TauType, mkTyVarTys, mkTyConApp,
mkSigmaTy, mkDictTy, isUnboxedType,
- splitAlgTyConApp
+ splitAlgTyConApp, classesToPreds
)
import TysWiredIn ( voidTy )
import Var ( TyVar )
= vcat (map pp_info inst_infos) $$ ppr extra_binds
where
pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
- = ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty]))
+ = ppr (mkSigmaTy tvs inst_decl_theta' (mkDictTy clas [ty]))
$$
ppr mbinds
+ where inst_decl_theta' = classesToPreds inst_decl_theta
\end{code}
= mkVanillaId (getName tycon) dummy_dfun_ty
-- The name is getSrcLoc'd in an error message
- dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
+ theta' = classesToPreds theta
+ dummy_dfun_ty = mkSigmaTy tyvars theta' voidTy
-- All we need from the dfun is its "theta" part, used during
-- equation simplification (tcSimplifyThetas). The final
-- dfun_id will have the superclass dictionaries as arguments too,
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsBinds(..), Stmt(..), StmtCtxt(..),
- mkMonoBind
+ mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
import BasicTypes ( RecFlag(..) )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, instOverloadedFun, newDicts )
+ LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs,
+ lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
+ newOverloadedLit, newMethod, newIPDict,
+ instOverloadedFun, newDicts, newClassDicts,
+ partitionLIEbyMeth, getIPsOfLIE
+ )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
-import TcSimplify ( tcSimplifyAndCheck )
+import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
)
import Id ( idType, recordSelectorFieldLabel,
isRecordSelector,
- Id
+ Id, mkVanillaId
)
import DataCon ( dataConFieldLabels, dataConSig, dataConId,
dataConStrictMarks, StrictnessMark(..)
)
-import Name ( Name )
+import Name ( Name, getName )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
+ ipName_maybe,
splitFunTy_maybe, splitFunTys, isNotUsgTy,
mkTyConApp,
splitForAllTys, splitRhoTy,
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import UsageSPUtils ( unannotTy )
-import VarSet ( elemVarSet, mkVarSet )
+import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy
\begin{code}
tcMonoExpr :: RenamedHsExpr -- Expession to type check
- -> TcTauType -- Expected type (could be a type variable)
+ -> TcTauType -- Expected type (could be a type variable)
-> TcM s (TcExpr, LIE)
tcMonoExpr (HsVar name) res_ty
returnTc (expr', lie)
\end{code}
+\begin{code}
+tcMonoExpr (HsIPVar name) res_ty
+ = let id = mkVanillaId name res_ty in
+ tcGetInstLoc (OccurrenceOf id) `thenNF_Tc` \ loc ->
+ newIPDict name res_ty loc `thenNF_Tc` \ ip ->
+ returnNF_Tc (HsIPVar id, unitLIE ip)
+\end{code}
+
%************************************************************************
%* *
\subsection{Literals}
tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
= tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
- [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
+ newClassDicts (LitLitOrigin (_UNPK_ s))
+ [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) ->
returnTc (HsLitOut lit res_ty, dicts)
\end{code}
tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
- [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
+ = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+ [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
returnNF_Tc arg_dicts -- Actually a singleton bag
result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
+ newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
(CCall lbl args' may_gc is_asm result_ty),
-- do the wrapping in the newtype constructor here
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
inst_env = mkTopTyVarSubst tyvars result_inst_tys
- theta' = substTheta inst_env theta
+ theta' = substClasses inst_env theta
in
- newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
+ newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
-- Phew!
returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
returnTc (expr, lie)
\end{code}
+Implicit Parameter bindings.
+
+\begin{code}
+tcMonoExpr (HsWith expr binds) res_ty
+ = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
+ tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
+ partitionLIEbyMeth isBound lie `thenTc` \ (ips, lie') ->
+ zonkLIE ips `thenTc` \ ips' ->
+ tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) ->
+ let expr'' = if nullMonoBinds dict_binds
+ then expr'
+ else HsLet (MonoBind dict_binds [] NonRecursive) expr' in
+ tcCheckIPBinds binds' types ips' `thenTc_`
+ returnTc (HsWith expr'' binds', lie')
+ where isBound p
+ = case ipName_maybe p of
+ Just n -> n `elem` names
+ Nothing -> False
+ names = map fst binds
+
+tcIPBinds ((name, expr) : binds)
+ = newTyVarTy_OpenKind `thenTc` \ ty ->
+ let id = mkVanillaId name ty in
+ tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
+ zonkTcType ty `thenTc` \ ty' ->
+ tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
+ returnTc ((id, expr') : binds', ty : types, lie `plusLIE` lie2)
+tcIPBinds [] = returnTc ([], [], emptyLIE)
+
+tcCheckIPBinds binds types ips
+ = foldrTc tcCheckIPBind (getIPsOfLIE ips) (zip binds types)
+
+-- ZZ how do we use the loc?
+tcCheckIPBind bt@((v, _), t1) ((n, t2) : ips) | getName v == n
+ = unifyTauTy t1 t2 `thenTc_`
+ tcCheckIPBind bt ips `thenTc` \ ips' ->
+ returnTc ips'
+tcCheckIPBind bt (ip : ips)
+ = tcCheckIPBind bt ips `thenTc` \ ips' ->
+ returnTc (ip : ips')
+tcCheckIPBind bt []
+ = returnTc []
+\end{code}
+
Typecheck expression which in most cases will be an Id.
\begin{code}
= zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsVar id')
+zonkExpr (HsIPVar id)
+ = zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsIPVar id')
+
zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
zonkExpr (HsLitOut lit ty)
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
+zonkExpr (HsWith expr binds)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkIPBinds binds `thenNF_Tc` \ new_binds ->
+ returnNF_Tc (HsWith new_expr new_binds)
+ where
+ zonkIPBinds = mapNF_Tc zonkIPBind
+ zonkIPBind (n, e) =
+ zonkExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (n, e')
+
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
#include "HsVersions.h"
-import Type ( tyVarsOfTypes )
-import Class ( classInstEnv, classExtraBigSig )
-import Unify ( matchTys )
+import Name ( Name )
+import Type ( Type, tyVarsOfTypes )
+import Class ( className, classInstEnv, classExtraBigSig )
+import Unify ( unifyTyListsX, matchTys )
import Subst ( mkSubst, substTy )
import TcMonad
import TcType ( zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( Inst, LookupInstResult(..),
- lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
+ lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE,
zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
-import VarSet ( emptyVarSet )
+import VarSet ( VarSet, emptyVarSet, unionVarSet )
import VarEnv ( emptyVarEnv )
import FunDeps ( instantiateFdClassTys )
-import Bag ( bagToList )
import Outputable
-import List ( elemIndex )
+import List ( elemIndex, nub )
\end{code}
-Improvement goes here.
-
\begin{code}
tcImprove lie =
if null cfdss then
else
-- zonkCfdss cfdss `thenTc` \ cfdss' ->
-- pprTrace "tcI" (ppr cfdss') $
- iterImprove cfdss
- where cfdss = getFunDepsOfLIE lie
-
+ iterImprove nfdss
+ where
+ cfdss = getFunDepsOfLIE lie
+ clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
+ classes = nub (map fst cfdss)
+ inst_nfdss = concatMap getInstNfdssOf classes
+ ips = getIPsOfLIE lie
+ ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
+ nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
+
+getInstNfdssOf clas = nfdss
+ where
+ nm = className clas
+ ins = classInstEnv clas
+ mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts)
+ nfdss = map mk_nfds ins
+
+iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s ()
iterImprove [] = returnTc ()
iterImprove cfdss
= -- zonkCfdss cfdss `thenTc` \ cfdss' ->
-- pprTrace "iterI" (ppr cfdss') $
- instImprove cfdss `thenTc` \ change1 ->
+ -- instImprove cfdss `thenTc` \ change1 ->
selfImprove pairImprove cfdss `thenTc` \ change2 ->
- if change1 || change2 then
+ if {- change1 || -} change2 then
iterImprove cfdss
else
returnTc ()
returnTc ((c, fds') : cfdss')
zonkCfdss [] = returnTc []
+{-
instImprove (cfds@(clas, fds) : cfdss)
= instImprove1 cfds ins `thenTc` \ changed ->
instImprove cfdss `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
where fds2 = instantiateFdClassTys clas ts
instImprove1 _ _ = returnTc False
-
+-}
+
+-- ZZ this will do a lot of redundant checking wrt instances
+-- it would do to make this operate over two lists, the first
+-- with only clas_nfds and ip_nfds, and the second with everything
+-- control would otherwise mimic the current loop, so that the
+-- caller could control whether the redundant inst improvements
+-- were avoided
+-- you could then also use this to check for consistency of new instances
selfImprove f [] = returnTc False
-selfImprove f (cfds : cfdss)
- = mapTc (f cfds) cfdss `thenTc` \ changes ->
+selfImprove f (nfds : nfdss)
+ = mapTc (f nfds) nfdss `thenTc` \ changes ->
anyTc changes `thenTc` \ changed ->
- selfImprove f cfdss `thenTc` \ rest_changed ->
+ selfImprove f nfdss `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
-pairImprove (clas1, fds1) (clas2, fds2)
- = if clas1 == clas2 then
- checkFds fds1 emptyVarSet fds2
+pairImprove (free1, n1, fds1) (free2, n2, fds2)
+ = if n1 == n2 then
+ checkFds (free1 `unionVarSet` free2) fds1 fds2
else
returnTc False
-checkFds [] free [] = returnTc False
-checkFds (fd1 : fd1s) free (fd2 : fd2s) =
- checkFd fd1 free fd2 `thenTc` \ change ->
- checkFds fd1s free fd2s `thenTc` \ changes ->
+checkFds free [] [] = returnTc False
+checkFds free (fd1 : fd1s) (fd2 : fd2s) =
+ checkFd free fd1 fd2 `thenTc` \ change ->
+ checkFds free fd1s fd2s `thenTc` \ changes ->
returnTc (change || changes)
--checkFds _ _ = returnTc False
-checkFd (t_x, t_y) free (s_x, s_y)
+checkFd free (t_x, t_y) (s_x, s_y)
-- we need to zonk each time because unification
-- may happen at any time
- = zonkMatchTys t_x free s_x `thenTc` \ msubst ->
+ = zonkUnifyTys free t_x s_x `thenTc` \ msubst ->
case msubst of
Just subst ->
- let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in
- zonkEqTys t_y s_y' `thenTc` \ eq ->
+ let t_y' = map (substTy (mkSubst emptyVarEnv subst)) t_y
+ s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y
+ in
+ zonkEqTys t_y' s_y' `thenTc` \ eq ->
if eq then
-- they're the same, nothing changes...
returnTc False
else
- unifyTauTyLists t_y s_y' `thenTc_`
+ -- ZZ what happens if two instance vars unify?
+ unifyTauTyLists t_y' s_y' `thenTc_`
-- if we get here, something must have unified
returnTc True
Nothing ->
Just (subst, []) -> -- pprTrace "zMT match!" empty $
returnTc (Just subst)
Nothing -> returnTc Nothing
+
+zonkUnifyTys free ts1 ts2
+ = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
+ mapTc zonkTcType ts2 `thenTc` \ ts2' ->
+ -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
+ case unifyTyListsX free ts2' ts1' of
+ Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $
+ returnTc (Just subst)
+ Nothing -> returnTc Nothing
\end{code}
Utilities:
import TcMonad
import RnMonad ( RnNameSupply, Fixities )
import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
+ newDicts, newClassDicts,
+ LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe, unUsgTy,
- splitAlgTyConApp_maybe,
- tyVarsOfTypes
+ splitTyConApp_maybe, splitDictTy_maybe,
+ getClassTys_maybe, splitAlgTyConApp_maybe,
+ classesToPreds, classesOfPreds,
+ unUsgTy, tyVarsOfTypes
)
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
tcHsTopType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
- (clas, inst_tys) = case splitDictTy_maybe dict_ty of
- Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
- Just pair -> pair
+ constr = classesOfPreds theta
+ (clas, inst_tys) = case splitDictTy_maybe dict_ty of
+ Just ct -> ct
+ Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
in
-- Check for respectable instance type, and context
-- instance CCallable [Char]
(if isLocallyDefined dfun_name then
scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint theta
+ mapNF_Tc scrutiniseInstanceConstraint constr
else
returnNF_Tc []
) `thenNF_Tc_`
-- Make the dfun id
let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
-- Add info from interface file
final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
in
- returnTc (unitBag (InstInfo clas tyvars inst_tys theta
+ returnTc (unitBag (InstInfo clas tyvars inst_tys constr
final_dfun_id
binds src_loc uprags))
\end{code}
dm_ids = [dm_id | (_, dm_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
in
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
+ newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
- newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
- newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
-- Check that all the method bindings come from this class
checkFromThisClass clas op_items monobinds `thenNF_Tc_`
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta'
- monobinds uprags True)
+ mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
+ (classesToPreds inst_decl_theta')
+ monobinds uprags True)
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, nameModule, isLocallyDefined )
import SrcLoc ( SrcLoc )
-import Type ( ThetaType, Type )
+import Type ( ThetaType, Type, ClassContext )
import PprType ( pprConstraint )
import Class ( classTyCon )
import DataCon ( DataCon )
Class -- Class, k
[TyVar] -- Type variables, tvs
[Type] -- The types at which the class is being instantiated
- ThetaType -- inst_decl_theta: the original context, c, from the
+ ClassContext -- inst_decl_theta: the original context, c, from the
-- instance declaration. It constrains (some of)
-- the TyVars above
Id -- The dfun id
\begin{code}
module TcMonad(
TcType,
- TcTauType, TcThetaType, TcRhoType,
+ TcTauType, TcPredType, TcThetaType, TcRhoType,
TcTyVar, TcTyVarSet,
TcKind,
import HsSyn ( HsLit )
import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type ( Type, Kind, ThetaType, RhoType, TauType,
+import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
import CmdLineOpts ( opt_PprStyle_Debug )
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
+type TcPredType = PredType
type TcThetaType = ThetaType
type TcRhoType = RhoType
type TcTauType = TauType
#include "HsVersions.h"
import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..),
- Sig(..), pprClassAssertion, pprParendHsType )
+ Sig(..), HsPred(..), pprHsPred, pprParendHsType )
import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
import TcHsSyn ( TcId )
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
-import Type ( Type, ThetaType, UsageAnn(..),
+import Type ( Type, PredType(..), ThetaType, UsageAnn(..),
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
mkUsForAllTy, zipFunTys,
mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
= tc_app ty1 [ty2]
tc_type_kind (MonoDictTy class_name tys)
- = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
+ = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) ->
returnTc (boxedTypeKind, mkDictTy clas arg_tys)
tc_type_kind (MonoUsgTy usg ty)
-- give overloaded functions like
-- f :: forall a. Num a => (# a->a, a->a #)
-- And we want these to get through the type checker
- check ct@(c,tys) | ambiguous = failWithTc (ambigErr ct tau)
- | otherwise = returnTc ()
+ check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
+ | otherwise = returnTc ()
where ct_vars = tyVarsOfTypes tys
forall_tyvars = map varName in_scope_vars
tau_vars = tyVarsOfType tau
mapTc tcClassAssertion context
where
- check_naughty (class_name, _)
+ check_naughty (HsPClass class_name _)
= checkTc (not (getUnique class_name `elem` cCallishClassKeys))
(naughtyCCallContextErr class_name)
+ check_naughty (HsPIParam _ _) = returnTc ()
-tcClassAssertion assn@(class_name, tys)
- = tcAddErrCtxt (appKindCtxt (pprClassAssertion assn)) $
+tcClassAssertion assn@(HsPClass class_name tys)
+ = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) ->
case thing of
-- Check with kind mis-match
checkTc (arity == n_tys) err `thenTc_`
unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_`
- returnTc (clas, arg_tys)
+ returnTc (Class clas arg_tys)
where
n_tys = length tys
err = arityErr "Class" class_name arity n_tys
+tcClassAssertion assn@(HsPIParam name ty)
+ = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
+ tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) ->
+ returnTc (IParam name arg_ty)
\end{code}
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, LIE,
- newMethod, newOverloadedLit, newDicts
+ newMethod, newOverloadedLit, newDicts, newClassDicts
)
import Name ( Name, getOccName, getSrcLoc )
import FieldLabel ( fieldLabelName )
dataConSourceArity
)
import Id ( Id, idType, isDataConId_maybe )
-import Type ( Type, isTauTy, mkTyConApp, boxedTypeKind )
-import Subst ( substTy, substTheta )
+import Type ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
+import Subst ( substTy, substClasses )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
-- cf tcExpr on LitLits
= tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
newDicts (LitLitOrigin (_UNPK_ s))
- [(cCallableClass, [pat_ty])] `thenNF_Tc` \ (dicts, _) ->
+ [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) ->
returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
\end{code}
in
tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
- ex_theta' = substTheta tenv ex_theta
+ ex_theta' = substClasses tenv ex_theta
arg_tys' = map (substTy tenv) arg_tys
n_ex_tvs = length ex_tvs
ex_tvs' = take n_ex_tvs all_tvs'
result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
in
- newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
+ newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
-- Check overall type matches
unifyTauTy pat_ty result_ty `thenTc_`
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst,
+ tyVarsOfInst, tyVarsOfInsts,
isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
- getDictClassTys,
+ getDictClassTys, getIPs,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
- Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
- plusLIE
+ Inst, LIE, pprInsts, pprInstsInFull,
+ mkLIE, emptyLIE, plusLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy )
import Id ( idType )
-import Bag ( bagToList )
import Class ( Class, classBigSig, classInstEnv )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
+import Type ( Type, ThetaType, TauType, ClassContext,
+ mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
import InstEnv ( InstEnv )
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
import VarSet
\begin{code}
tcSimplify
:: SDoc
- -> TopLevelFlag
-> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
-> LIE -- Wanted
TcDictBinds, -- Bindings
LIE) -- Remaining wanteds; no dups
-tcSimplify str top_lvl local_tvs wanted_lie
+tcSimplify str local_tvs wanted_lie
+{-
| isEmptyVarSet local_tvs
= returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
| otherwise
+-}
= reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
-- Check for non-generalisable insts
(irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
in
+ -- pprTrace "tcS" (ppr (frees, irreds')) $
+ -- pprTrace "tcS bad" (ppr bad_guys) $
addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
-- dependencies as hidden constraints (i.e. they'd only
-- show up in interface files) -- or maybe they'd be useful
-- as first class predicates...
- wanteds = filter notFunDep (bagToList wanted_lie)
+ wanteds = filter notFunDep (lieToList wanted_lie)
try_me inst
-- Does not constrain a local tyvar
| isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ && null (getIPs inst)
= -- if is_top_level then
-- FreeIfTautological -- Special case for inference on
-- -- top-level defns
-- Done
returnTc (mkLIE frees, binds)
where
- givens = bagToList given_lie
+ givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (bagToList wanted_lie)
+ wanteds = filter notFunDep (lieToList wanted_lie)
given_dicts = filter isDict givens
try_me inst
returnTc (mkLIE irreds, binds)
where
-- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (bagToList wanted_lie)
+ wanteds = filter notFunDep (lieToList wanted_lie)
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = DontReduce
-- Invariant: these Insts are already in the finite mapping
-pprAvails avails = vcat (map pp (eltsFM avails))
- where
- pp (Avail main_id rhs ids)
- = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
+pprAvails avails = vcat (map pprAvail (eltsFM avails))
+
+pprAvail (Avail main_id rhs ids)
+ = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
pprRhs NoRhs = text "<no rhs>"
pprRhs (Rhs rhs b) = ppr rhs
-- This assertion isn't necessarily true. It's permitted
-- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
-- and when typechecking instance decls we generate redundant "givens" too.
- addAvail avails given avail
+ -- addAvail avails given avail
+ addAvail avails given avail `thenNF_Tc` \av ->
+ zonkInst given `thenNF_Tc` \given' ->
+ returnNF_Tc av
where
avail = Avail (instToId given) NoRhs []
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
+ sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
\begin{code}
tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
- -> ThetaType -- Wanted
- -> TcM s ThetaType -- Needed
+ -> ClassContext -- Wanted
+ -> TcM s ClassContext -- Needed
tcSimplifyThetas inst_mapper wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ThetaType -- Given
- -> ThetaType -- Wanted
+tcSimplifyCheckThetas :: ClassContext -- Given
+ -> ClassContext -- Wanted
-> TcM s ()
tcSimplifyCheckThetas givens wanteds
\begin{code}
-type AvailsSimple = FiniteMap (Class, [TauType]) Bool
+type AvailsSimple = FiniteMap (Class,[Type]) Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: (Class -> InstEnv)
- -> ThetaType -- Given
- -> ThetaType -- Wanted
- -> NF_TcM s ThetaType -- Irreducible
+ -> ClassContext -- Given
+ -> ClassContext -- Wanted
+ -> NF_TcM s ClassContext -- Irreducible
reduceSimple inst_mapper givens wanteds
= reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Int,ThetaType) -- Stack
+reduce_simple :: (Int,ClassContext) -- Stack
-> (Class -> InstEnv)
-> AvailsSimple
- -> ThetaType
+ -> ClassContext
-> NF_TcM s AvailsSimple
reduce_simple (n,stack) inst_mapper avails wanteds
Nothing -> returnNF_Tc (addIrred givens wanted)
Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
-addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
-addIrred givens ct
+addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addIrred givens ct@(clas,tys)
= addSCs (addToFM givens ct True) ct
-addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
-addNonIrred givens ct
+addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addNonIrred givens ct@(clas,tys)
= addSCs (addToFM givens ct False) ct
addSCs givens ct@(clas,tys)
= foldl add givens sc_theta
where
(tyvars, sc_theta_tmpl, _, _) = classBigSig clas
- sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
+ sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
- add givens ct = case lookupFM givens ct of
- Nothing -> -- Add it and its superclasses
- addSCs (addToFM givens ct False) ct
+ add givens ct@(clas, tys)
+ = case lookupFM givens ct of
+ Nothing -> -- Add it and its superclasses
+ addSCs (addToFM givens ct False) ct
- Just True -> -- Set its flag to False; superclasses already done
- addToFM givens ct False
+ Just True -> -- Set its flag to False; superclasses already done
+ addToFM givens ct False
- Just False -> -- Already done
- givens
+ Just False -> -- Already done
+ givens
\end{code}
-- No sense in repeatedly zonking lots of
-- constant constraints so filter them out here
(lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
- (bagToList init_lie)
+ (lieToList init_lie)
try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
| otherwise = Free
\end{code}
returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
-- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (bagToList wanted_lie)
+ wanteds = filter notFunDep (lieToList wanted_lie)
try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
- complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
+ complain d | not (null (getIPs d)) = addTopIPErr d
+ | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
| otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
where
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+addTopIPErr dict
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+
-- Used for top-level irreducibles
addTopInstanceErr dict
= addInstErrTcM (instLoc dict)
ptext SLIT("Probable cause:") <+>
vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
ptext SLIT("in") <+> str],
- if all_tyvars then empty else
+ if isDict dict && all_tyvars then empty else
ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
where
import HsSyn ( HsDecl(..), TyClDecl(..),
HsType(..), HsTyVar,
ConDecl(..), ConDetails(..), BangType(..),
- Sig(..),
+ Sig(..), HsPred(..),
tyClDeclName, isClassDecl, isSynDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name )
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _)
- = Just (decl, getUnique name, map (getUnique . fst) ctxt)
+ = Just (decl, getUnique name, map (getUnique . get_clas) ctxt)
mk_cls_edges other_decl
= Nothing
----------------------------------------------------
-get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
+get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt)
+get_clas (HsPClass clas _) = clas
----------------------------------------------------
get_deriv Nothing = emptyUniqSet
tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
tcContext, tcHsTopTypeKind
)
-import TcType ( zonkTcTyVarToTyVar, zonkTcThetaType )
+import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
import TcEnv ( tcLookupTy, TcTyThing(..) )
import TcMonad
import TcUnify ( unifyKind )
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
mkTyVarTy,
mkArrowKind, mkArrowKinds, boxedTypeKind,
- isUnboxedType, Type, ThetaType
+ isUnboxedType, Type, ThetaType, classesOfPreds
)
import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
-- Typecheck the pieces
tcContext context `thenTc` \ ctxt ->
- mapTc (tcConDecl rec_tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
+ let ctxt' = classesOfPreds ctxt in
+ mapTc (tcConDecl rec_tycon tyvars ctxt') con_decls `thenTc` \ data_cons ->
tc_derivs derivings `thenTc` \ derived_classes ->
let
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
tycon_name
- tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
+ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
data_cons
derived_classes
Nothing -- Not a dictionary
%************************************************************************
\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon
+tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon
tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
tcExtendTyVarScope ex_tvs $ \ ex_tyvars ->
tcContext ex_ctxt `thenTc` \ ex_theta ->
- tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
+ let ex_ctxt' = classesOfPreds ex_theta in
+ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_ctxt' details
tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
= case details of
-- immutable type variables. (The top-level tyvars are
-- already fixed, by the preceding kind-inference pass.)
mapNF_Tc zonkTcTyVarToTyVar ex_tyvars `thenNF_Tc` \ ex_tyvars' ->
- zonkTcThetaType ex_theta `thenNF_Tc` \ ex_theta' ->
+ zonkTcClassConstraints ex_theta `thenNF_Tc` \ ex_theta' ->
let
data_con = mkDataCon name arg_stricts fields
tyvars (thinContext arg_tys ctxt)
--------------------------------
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr,
- zonkTcType, zonkTcTypes, zonkTcThetaType,
+ zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
zonkTcTypeToType, zonkTcTyVarToTyVar,
zonkTcKindToKind
import TypeRep ( Type(..), Kind, TyNote(..),
typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
) -- friend
-import Type ( ThetaType,
+import Type ( ThetaType, PredType(..),
mkAppTy, mkTyConApp,
- splitDictTy_maybe, splitForAllTys, isNotUsgTy,
+ splitPredTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
)
import Subst ( Subst, mkTopTyVarSubst, substTy )
where
-- A type variable is never instantiated to a dictionary type,
-- so we don't need to do a tcReadVar on the "arg".
- go syn_t (FunTy arg res) ts = case splitDictTy_maybe arg of
+ go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of
Just pair -> go res res (pair:ts)
Nothing -> returnNF_Tc (reverse ts, syn_t)
go syn_t (NoteTy _ t) ts = go syn_t t ts
zonkTcTypes :: [TcType] -> NF_TcM s [TcType]
zonkTcTypes tys = mapNF_Tc zonkTcType tys
+zonkTcClassConstraints cts = mapNF_Tc zonk cts
+ where zonk (clas, tys)
+ = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
+ returnNF_Tc (clas, new_tys)
+
zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType
-zonkTcThetaType theta = mapNF_Tc zonk theta
- where
- zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (c, new_ts)
+zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
+
+zonkTcPredType :: TcPredType -> NF_TcM s TcPredType
+zonkTcPredType (Class c ts) =
+ zonkTcTypes ts `thenNF_Tc` \ new_ts ->
+ returnNF_Tc (Class c new_ts)
+zonkTcPredType (IParam n t) =
+ zonkTcType t `thenNF_Tc` \ new_t ->
+ returnNF_Tc (IParam n new_t)
zonkTcKind :: TcKind -> NF_TcM s TcKind
zonkTcKind = zonkTcType
go (NoteTy (UsgForAll uv) ty2)= go ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (NoteTy (UsgForAll uv) ty2')
+ go (NoteTy (IPNote nm) ty2) = go ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (NoteTy (IPNote nm) ty2')
+
go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
go res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res')
Class, ClassOpItem,
mkClass, classTyVars,
- classKey, classSelIds, classTyCon,
+ classKey, className, classSelIds, classTyCon,
classBigSig, classExtraBigSig, classInstEnv, classTvsFds
) where
_interface_ PprType 1
_exports_
-PprType pprType;
+PprType pprType pprPred;
_declarations_
1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;;
+1 pprPred _:_ Type.PredType -> Outputable.SDoc ;;
__interface PprType 1 0 where
-__export PprType pprType ;
+__export PprType pprType pprPred ;
1 pprType :: TypeRep.Type -> Outputable.SDoc ;
+1 pprPred :: Type.PredType -> Outputable.SDoc ;
module PprType(
pprKind, pprParendKind,
pprType, pprParendType,
- pprConstraint, pprTheta,
+ pprConstraint, pprPred, pprTheta,
pprTyVarBndr, pprTyVarBndrs,
-- Junk
import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..),
boxedTypeKind,
) -- friend
-import Type ( ThetaType,
- splitDictTy_maybe,
+import Type ( PredType(..), ThetaType,
+ splitPredTy_maybe,
splitForAllTys, splitSigmaTy, splitRhoTy,
isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
splitUsForAllTys
maybeTyConSingleCon, isEnumerationTyCon,
tyConArity, tyConUnique
)
-import Class ( Class )
+import Class ( Class, className )
-- others:
import Maybes ( maybeToBool )
pprKind = pprType
pprParendKind = pprParendType
+pprPred :: PredType -> SDoc
+pprPred (Class clas tys) = pprConstraint clas tys
+pprPred (IParam n ty) = ppr n <+> ppr ty
+
pprConstraint :: Class -> [Type] -> SDoc
pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
- where
- ppr_dict (c,tys) = pprConstraint c tys
+pprTheta theta = parens (hsep (punctuate comma (map pprPred theta)))
instance Outputable Type where
ppr ty = pprType ty
-- DICTIONARY CASE, prints {C a}
-- This means that instance decls come out looking right in interfaces
-- and that in turn means they get "gated" correctly when being slurped in
- | maybeToBool maybe_dict
- = braces (ppr_dict env tYCON_PREC ctys)
+ | maybeToBool maybe_pred
+ = braces (ppr_pred env pred)
-- NO-ARGUMENT CASE (=> no parens)
| null tys
tycon_uniq = tyConUnique tycon
n_tys = length tys
(ty1:_) = tys
- Just ctys = maybe_dict
- maybe_dict = splitDictTy_maybe ty -- Checks class and arity
+ Just pred = maybe_pred
+ maybe_pred = splitPredTy_maybe ty -- Checks class and arity
tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys)
pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
ppr_theta [] = empty
- ppr_theta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
+ ppr_theta theta = parens (hsep (punctuate comma (map ppr_pred theta)))
<+> ptext SLIT("=>")
- ppr_dict (clas,tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
-
+ ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
+ ppr_pred (IParam n ty) = hsep [char '?' <> ppr n, text "::",
+ ppr_ty env tYCON_PREC ty]
ppr_ty env ctxt_prec (FunTy ty1 ty2)
= maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2))
= maybeParen ctxt_prec tYCON_PREC $
ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty
+ppr_ty env ctxt_prec (NoteTy (IPNote nm) ty)
+ = braces (ppr_pred env (IParam nm ty))
+
ppr_theta env [] = empty
-ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
+ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_pred env) theta)))
+
+ppr_pred env (Class clas tys) = ppr clas <+>
+ hsep (map (ppr_ty env tYCON_PREC) tys)
+ppr_pred env (IParam n ty) = hsep [char '?' <> ppr n, text "::",
+ ppr_ty env tYCON_PREC ty]
+{-
ppr_dict env ctxt (clas, tys) = ppr clas <+>
hsep (map (ppr_ty env tYCON_PREC) tys)
+-}
\end{code}
\begin{code}
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkDictTy, splitDictTy_maybe, isDictTy,
+ mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
isForAllTy, applyTy, applyTys, mkPiType,
- TauType, RhoType, SigmaType, ThetaType,
- isTauTy,
- mkRhoTy, splitRhoTy,
+ TauType, RhoType, SigmaType, PredType(..), ThetaType,
+ ClassPred, ClassContext, mkClassPred,
+ getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
+ isTauTy, mkRhoTy, splitRhoTy,
mkSigmaTy, splitSigmaTy,
-- Lifting and boxity
typePrimRep,
-- Free variables
- tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
- addFreeTyVars,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
+ namesOfType, typeKind, addFreeTyVars,
-- Tidying up for printing
tidyType, tidyTypes,
-- Other imports:
import {-# SOURCE #-} DataCon( DataCon, dataConType )
-import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
+import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
import VarEnv
import VarSet
-import Name ( NamedThing(..), mkLocalName, tidyOccName,
+import Name ( Name, NamedThing(..), mkLocalName, tidyOccName,
)
import NameSet
import Class ( classTyCon, Class )
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = TyConApp (classTyCon clas) tys
+mkPredTy :: PredType -> Type
+mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys
+mkPredTy (IParam n ty) = NoteTy (IPNote n) ty
+
+{-
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
splitDictTy_maybe (TyConApp tc tys)
| maybeToBool maybe_class
splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
splitDictTy_maybe other = Nothing
+-}
+
+splitPredTy_maybe :: Type -> Maybe PredType
+splitPredTy_maybe (TyConApp tc tys)
+ | maybeToBool maybe_class
+ && tyConArity tc == length tys = Just (Class clas tys)
+ where
+ maybe_class = tyConClass_maybe tc
+ Just clas = maybe_class
+
+splitPredTy_maybe (NoteTy (IPNote n) ty)
+ = Just (IParam n ty)
+splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
+splitPredTy_maybe other = Nothing
+
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
+splitDictTy_maybe ty
+ = case splitPredTy_maybe ty of
+ Just p -> getClassTys_maybe p
+ Nothing -> Nothing
isDictTy :: Type -> Bool
-- This version is slightly more efficient than (maybeToBool . splitDictTy)
%************************************************************************
%* *
\subsection{Stuff to do with the source-language types}
+
+PredType and ThetaType are used in types for expressions and bindings.
+ClassPred and ClassContext are used in class and instance declarations.
%* *
%************************************************************************
\begin{code}
type RhoType = Type
type TauType = Type
-type ThetaType = [(Class, [Type])]
+data PredType = Class Class [Type]
+ | IParam Name Type
+type ThetaType = [PredType]
+type ClassPred = (Class, [Type])
+type ClassContext = [ClassPred]
type SigmaType = Type
\end{code}
+\begin{code}
+instance Outputable PredType where
+ ppr = pprPred
+\end{code}
+
+\begin{code}
+mkClassPred clas tys = Class clas tys
+
+getClassTys_maybe :: PredType -> Maybe ClassPred
+getClassTys_maybe (Class clas tys) = Just (clas, tys)
+getClassTys_maybe _ = Nothing
+
+ipName_maybe :: PredType -> Maybe Name
+ipName_maybe (IParam n _) = Just n
+ipName_maybe _ = Nothing
+
+classesToPreds cts = map (uncurry Class) cts
+
+classesOfPreds theta = concatMap cvt theta
+ where cvt (Class clas tys) = [(clas, tys)]
+ cvt (IParam _ _ ) = []
+\end{code}
+
@isTauTy@ tests for nested for-alls.
\begin{code}
\end{code}
\begin{code}
-mkRhoTy :: [(Class, [Type])] -> Type -> Type
-mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
+mkRhoTy :: [PredType] -> Type -> Type
+mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
-splitRhoTy :: Type -> ([(Class, [Type])], Type)
+splitRhoTy :: Type -> ([PredType], Type)
splitRhoTy ty = split ty ty []
where
- split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
- Just pair -> split res res (pair:ts)
+ split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
+ Just p -> split res res (p:ts)
Nothing -> (reverse ts, orig_ty)
split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
split orig_ty ty ts = (reverse ts, orig_ty)
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
-splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
+splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
where
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
+tyVarsOfType (NoteTy (IPNote _) ty) = tyVarsOfType ty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+tyVarsOfPred :: PredType -> TyVarSet
+tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
+tyVarsOfPred (IParam n ty) = tyVarsOfType ty
+
+tyVarsOfTheta :: ThetaType -> TyVarSet
+tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+
-- Add a Note with the free tyvars to the top of the type
-- (but under a usage if there is one)
addFreeTyVars :: Type -> Type
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
+ go_note note@(IPNote _) = note -- IP is already tidy
tidyTypes env tys = map (tidyType env) tys
\end{code}
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
+seqNote (IPNote nm) = nm `seq` ()
\end{code}
import VarEnv
import VarSet
-import Name ( Provenance(..), ExportFlag(..),
+import Name ( Name, Provenance(..), ExportFlag(..),
mkWiredInTyConName, mkGlobalName, mkKindOccFS, tcName,
)
import TyCon ( TyCon, KindCon,
| FTVNote TyVarSet -- The free type variables of the noted expression
| UsgNote UsageAnn -- The usage annotation at this node
| UsgForAll UVar -- Annotation variable binder
+ | IPNote Name -- It's an implicit parameter
data UsageAnn
= UsOnce -- Used at most once
unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
+-- IP notes need to be preserved
+unannotTy ty@(NoteTy (IPNote _) _) = ty
unannotTy ty@(TyVarTy _) = ty
unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
projects / ghc-hetmet.git / commitdiff