Commit 266fadd9 authored by lewie's avatar lewie

[project @ 2000-01-28 20:52:37 by lewie]

First pass at implicit parameters.  Honest, I didn't really go in *intending*
to modify every file in the typechecker... ;-)  The breadth of the change
is partly due to generalizing contexts so that they are not hardwired to
be (Class, [Type]) pairs.  See types/Type.lhs for details (look for PredType).
parent c39373f1
......@@ -26,10 +26,10 @@ import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
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,
......@@ -84,10 +84,10 @@ data DataCon
-- 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
......@@ -204,8 +204,8 @@ instance Show DataCon where
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
-> [TyVar] -> ClassContext
-> [TyVar] -> ClassContext
-> [TauType] -> TyCon
-> Id
-> DataCon
......@@ -238,7 +238,7 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t
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)))
......@@ -246,7 +246,7 @@ mk_dict_strict_mark (clas,tys)
| opt_DictsStrict &&
-- Don't mark newtype things as strict!
isDataTyCon (classTyCon clas) = MarkedStrict
| otherwise = NotMarkedStrict
| otherwise = NotMarkedStrict
\end{code}
\begin{code}
......@@ -287,8 +287,8 @@ dataConRepStrictness dc
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,
......
......@@ -41,8 +41,8 @@ import TysWiredIn ( boolTy, charTy, mkListTy )
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,
......@@ -50,7 +50,7 @@ import Type ( Type, ThetaType,
)
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 )
......@@ -156,7 +156,7 @@ mkDataConId data_con
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}
......@@ -460,16 +460,16 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> 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.
......
......@@ -11,7 +11,7 @@ module Name (
-- The Name type
Name, -- Abstract
mkLocalName, mkImportedLocalName, mkSysLocalName,
mkTopName,
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
......@@ -133,6 +133,13 @@ mkTopName uniq mod fs
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
......
......@@ -7,8 +7,8 @@
\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
......@@ -16,10 +16,10 @@ module OccName (
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,
......@@ -82,11 +82,12 @@ pprEncodedFS fs
\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,
......@@ -99,11 +100,13 @@ dataName = DataName
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"
......@@ -234,6 +237,9 @@ isDataOcc oter = False
-- Pretty inefficient!
isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
isIPOcc (OccName IPName _) = True
isIPOcc _ = False
\end{code}
......@@ -277,7 +283,7 @@ mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str)
\end{code}
\begin{code}
mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc
:: OccName -> OccName
......@@ -288,6 +294,7 @@ mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it
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"
......
......@@ -23,7 +23,7 @@ module Subst (
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
substTy, substTheta,
substTy, substClasses, substTheta,
-- Expression stuff
substExpr, substIdInfo
......@@ -38,7 +38,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..),
) -- friend
import Type ( ThetaType,
import Type ( ThetaType, PredType(..), ClassContext,
tyVarsOfType, tyVarsOfTypes, mkAppTy
)
import VarSet
......@@ -262,10 +262,19 @@ substTy :: Subst -> Type -> Type
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
......@@ -277,6 +286,7 @@ subst_ty subst 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
......
......@@ -118,6 +118,7 @@ dsLet (MonoBind binds sigs is_rec) body
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
dsExpr e@(HsVar var) = returnDs (Var var)
dsExpr e@(HsIPVar var) = returnDs (Var var)
\end{code}
%************************************************************************
......@@ -319,7 +320,15 @@ dsExpr (HsCase discrim matches src_loc)
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
......
......@@ -113,14 +113,14 @@ instance (Outputable name, Outputable pat)
\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
......@@ -129,7 +129,7 @@ data TyClDecl name pat
(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
......@@ -172,7 +172,7 @@ instance (Outputable name, Outputable pat)
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
......@@ -190,7 +190,7 @@ instance (Outputable name, Outputable pat)
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
......@@ -239,7 +239,7 @@ data ConDecl name
= 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)
......@@ -269,7 +269,7 @@ data BangType 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]
......
......@@ -35,6 +35,7 @@ import SrcLoc ( SrcLoc )
\begin{code}
data HsExpr id pat
= HsVar id -- variable
| HsIPVar id -- implicit parameter
| HsLit HsLit -- literal
| HsLitOut HsLit -- TRANSLATION
Type -- (with its type)
......@@ -79,6 +80,9 @@ data HsExpr id pat
| 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
......@@ -209,6 +213,7 @@ pprExpr e = pprDeeper (ppr_expr e)
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
......@@ -292,6 +297,9 @@ ppr_expr (HsLet binds expr)
= 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
......@@ -381,6 +389,7 @@ pprParendExpr expr
HsLitOut l _ -> ppr l
HsVar _ -> pp_as_was
HsIPVar _ -> pp_as_was
ExplicitList _ -> pp_as_was
ExplicitListOut _ _ -> pp_as_was
ExplicitTuple _ _ -> pp_as_was
......
......@@ -6,13 +6,13 @@
\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"
......@@ -26,15 +26,17 @@ import Util ( thenCmp, cmpList )
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
......@@ -121,13 +123,19 @@ instance (Outputable name) => Outputable (HsTyVar name) where
-- 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}
......@@ -148,7 +156,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
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
......@@ -213,17 +221,17 @@ in checking interfaces. Most any other use is likely to be {\em
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
......@@ -231,7 +239,7 @@ cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsType
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)
......@@ -272,11 +280,15 @@ cmpHsType cmp ty1 ty2 -- tags must be different
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
......
......@@ -48,7 +48,8 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
)
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
)
......@@ -260,7 +261,8 @@ ifaceInstances if_hdl inst_infos
-- 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,
......@@ -494,7 +496,7 @@ ifaceTyCon tycon
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("="),
......@@ -528,7 +530,7 @@ ifaceTyCon tycon
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
......@@ -547,7 +549,7 @@ ifaceTyCon tycon
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,
......@@ -576,9 +578,17 @@ ppr_decl_context :: ThetaType -> SDoc
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}
%************************************************************************
......
......@@ -128,6 +128,7 @@ data Token
| ITlabel
| ITdynamic
| ITunsafe
| ITwith
| ITstdcallconv
| ITccallconv
......@@ -208,6 +209,8 @@ data Token
| ITqvarsym (FAST_STRING,FAST_STRING)
| ITqconsym (FAST_STRING,FAST_STRING)
| ITipvarid FAST_STRING -- GHC extension: implicit param: ?x
| ITpragma StringBuffer
| ITchar Char
......@@ -282,6 +285,7 @@ ghcExtensionKeywordsFM = listToUFM $
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "unsafe", ITunsafe ),
( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
("_ccall_", ITccall (False, False, False)),
......@@ -590,6 +594,8 @@ lexToken cont glaexts buf =
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
......@@ -892,12 +898,18 @@ is_ident = is_ctype 1
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 ->
......
......@@ -137,15 +137,15 @@ checkInstType t
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)
......@@ -239,6 +239,7 @@ patterns).
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.
......@@ -19,7 +19,7 @@ import Lex
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
......@@ -85,6 +85,7 @@ Conflicts: 14 shift/reduce
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
'with' { ITwith }
'_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
......@@ -173,6 +174,7 @@ Conflicts: 14 shift/reduce
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
IPVARID { ITipvarid $$ }
PRAGMA { ITpragma $$ }
......@@ -633,6 +635,7 @@ gdrh :: { RdrNameGRHS }
exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 }
| infixexp 'with' dbinding { HsWith $1 $3 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
......@@ -683,6 +686,7 @@ aexp :: { RdrNameHsExpr }
aexp1 :: { RdrNameHsExpr }
: qvar { HsVar $1 }
| IPVARID { HsIPVar (mkSrcUnqual ipName $1) }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
......@@ -815,6 +819,22 @@ fbinds :: { RdrNameHsRecordBinds }
fbind :: { (RdrName, RdrNameHsExpr, Bool) }
: 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.
......
......@@ -88,7 +88,7 @@ type RdrNameBangType = BangType 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
......@@ -147,12 +147,13 @@ extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
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