Commit 461f1fb5 authored by lewie's avatar lewie

[project @ 2000-02-09 18:32:09 by lewie]

Misc. fixes to implicit parameters support.
parent 0198d561
......@@ -137,7 +137,8 @@ mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = uniq,
n_sort = Local,
n_occ = mkIPOcc occ,
n_occ = occ,
-- ZZ is this an appropriate provinence?
n_prov = SystemProv }
------------------------- Wired in names -------------------------
......@@ -240,6 +241,7 @@ all_toplev_ids_visible =
opt_EnsureSplittableC -- Splitting requires visiblilty
\end{code}
\begin{code}
setNameProvenance :: Name -> Provenance -> Name
-- setNameProvenance used to only change the provenance of
......
......@@ -213,7 +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 (HsIPVar v) = {- char '?' <> -} ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsLitOut lit _) = ppr lit
......
......@@ -52,6 +52,8 @@ data HsType name
| MonoTupleTy [HsType name] -- Element types (length gives arity)
Bool -- boxed?
| MonoIParamTy name (HsType name)
-- these next two are only used in interfaces
| MonoDictTy name -- Class
[HsType name]
......@@ -135,7 +137,7 @@ 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]
= hsep [{- char '?' <> -} ppr n, text "::", ppr ty]
\end{code}
\begin{code}
......
......@@ -50,7 +50,7 @@ import Class ( Class, classExtraBigSig )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
deNoteType, classesToPreds,
Type, ThetaType
Type, ThetaType, PredType(..), ClassContext
)
import PprType
......@@ -578,15 +578,21 @@ 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 :: ClassContext -> 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 [pprPred p | p <- theta]))
pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
pprIfaceClasses :: [(Class,[Type])] -> SDoc
-- ZZ - not sure who uses this - i.e. whether IParams really show up or not
-- (it's not used to print normal value signatures)
pprIfacePred :: PredType -> SDoc
pprIfacePred (Class clas tys) = pprConstraint clas tys
pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty
pprIfaceClasses :: ClassContext -> SDoc
pprIfaceClasses [] = empty
pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
\end{code}
......
......@@ -595,7 +595,7 @@ lexToken cont glaexts buf =
cont (ITunknown "\NUL") (stepOn buf)
'?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
lex_ip cont (setCurrentPos# buf 1#)
lex_ip cont (stepOn buf)
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
......
......@@ -136,13 +136,21 @@ checkInstType t
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (MonoTupleTy ts True)
= mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
returnP (map (uncurry HsPClass) cs)
= mapP (\t -> checkPred t []) ts `thenP` \ps ->
returnP ps
checkContext (MonoTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
= checkAssertion t [] `thenP` \(c,ts) ->
returnP [HsPClass c ts]
= checkPred t [] `thenP` \p ->
returnP [p]
checkPred :: RdrNameHsType -> [RdrNameHsType]
-> P (HsPred RdrName)
checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (HsPClass t args)
checkPred (MonoTyApp l r) args = checkPred l (r:args)
checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"
checkAssertion :: RdrNameHsType -> [RdrNameHsType]
-> P (HsClassAssertion RdrName)
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $
$Id: Parser.y,v 1.20 2000/02/09 18:32:10 lewie Exp $
Haskell grammar.
......@@ -35,6 +35,7 @@ import GlaExts
{-
-----------------------------------------------------------------------------
Conflicts: 14 shift/reduce
(note: it's currently 21 -- JRL, 31/1/2000)
8 for abiguity in 'if x then y else z + 1'
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
......@@ -85,7 +86,6 @@ Conflicts: 14 shift/reduce
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
'with' { ITwith }
'_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
......@@ -94,6 +94,7 @@ Conflicts: 14 shift/reduce
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
'with' { ITwith }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'_ccall_' { ITccall (False, False, False) }
......@@ -174,7 +175,8 @@ Conflicts: 14 shift/reduce
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
IPVARID { ITipvarid $$ }
IPVARID { ITipvarid $$ } -- GHC extension
PRAGMA { ITpragma $$ }
......@@ -489,6 +491,7 @@ type :: { RdrNameHsType }
btype :: { RdrNameHsType }
: btype atype { MonoTyApp $1 $2 }
| IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
| atype { $1 }
atype :: { RdrNameHsType }
......
......@@ -145,7 +145,8 @@ import Ratio ( (%) )
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
IPVARID { ITipvarid $$ }
IPVARID { ITipvarid $$ } -- GHC extension
PRAGMA { ITpragma $$ }
......@@ -452,6 +453,7 @@ atype : qtc_name { MonoTyVar $1 }
| '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} }
| '[' type ']' { MonoListTy $2 }
| '{' qcls_name atypes '}' { MonoDictTy $2 $3 }
| '{' IPVARID '::' type '}' { MonoIParamTy (mkSysUnqual ipName $2) $4 }
| '(' type ')' { $2 }
-- This one is dealt with via qtc_name
......
......@@ -25,10 +25,11 @@ module Inst (
lookupInst, lookupSimpleInst, LookupInstResult(..),
isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
instBindingRequired, instCanBeGeneralised,
zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
instToId, instToIdBndr, ipToId,
InstOrigin(..), InstLoc, pprInstLoc
) where
......@@ -52,7 +53,8 @@ import Class ( classInstEnv, Class )
import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
getOccName, nameUnique )
import PprType ( pprPred )
import InstEnv ( InstEnv, lookupInstEnv )
import SrcLoc ( SrcLoc )
......@@ -310,8 +312,11 @@ Predicates
~~~~~~~~~~
\begin{code}
isDict :: Inst -> Bool
isDict (Dict _ (Class _ _) _) = True
isDict (Dict _ _ _) = True
isDict other = False
isClassDict :: Inst -> Bool
isClassDict (Dict _ (Class _ _) _) = True
isClassDict other = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ _ loc)
......@@ -485,9 +490,7 @@ instToIdBndr :: Inst -> TcId
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
= ipToId n ty loc
instToIdBndr (Method u id tys theta tau (_,loc,_))
= mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
......@@ -497,6 +500,9 @@ instToIdBndr (LitInst u list ty loc)
instToIdBndr (FunDep clas fds _)
= panic "FunDep escaped!!!"
ipToId n ty loc
= mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
\end{code}
......@@ -539,6 +545,8 @@ zonkInst (FunDep clas fds loc)
= zonkFunDeps fds `thenNF_Tc` \ fds' ->
returnNF_Tc (FunDep clas fds' loc)
zonkInsts insts = mapNF_Tc zonkInst insts
zonkFunDeps fds = mapNF_Tc zonkFd fds
where
zonkFd (ts1, ts2)
......
......@@ -291,7 +291,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
let ips = getIPsOfLIE lie_req in
if null real_tyvars_to_gen_list && null ips then
if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
-- No polymorphism, and no IPs, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
......
......@@ -25,7 +25,7 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
newOverloadedLit, newMethod, newIPDict,
instOverloadedFun, newDicts, newClassDicts,
partitionLIEbyMeth, getIPsOfLIE
partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
......@@ -200,10 +200,11 @@ tcMonoExpr (HsVar name) res_ty
\begin{code}
tcMonoExpr (HsIPVar name) res_ty
-- ZZ What's the `id' used for here...
= 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)
returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
\end{code}
%************************************************************************
......@@ -746,7 +747,8 @@ tcMonoExpr (HsWith expr binds) res_ty
tcIPBinds ((name, expr) : binds)
= newTyVarTy_OpenKind `thenTc` \ ty ->
let id = mkVanillaId name ty in
tcGetSrcLoc `thenTc` \ loc ->
let id = ipToId name ty loc in
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
zonkTcType ty `thenTc` \ ty' ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
......
......@@ -12,7 +12,7 @@ import TcMonad
import TcType ( zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( Inst, LookupInstResult(..),
lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE,
lookupInst, 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
......
......@@ -198,13 +198,13 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty)
-- f :: forall a. Num a => (# a->a, a->a #)
-- And we want these to get through the type checker
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
ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
not (ct_var `elemUFM` tau_vars)
ambiguous = foldUFM ((||) . ambig) False ct_vars
check _ = returnTc ()
in
mapTc check theta `thenTc_`
returnTc (body_kind, mkSigmaTy tyvars theta tau)
......
......@@ -132,7 +132,8 @@ import TcHsSyn ( TcExpr, TcId,
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst, tyVarsOfInsts,
isDict, isStdClassTyVarDict, isMethodFor, notFunDep,
isDict, isClassDict, isStdClassTyVarDict,
isMethodFor, notFunDep,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
getDictClassTys, getIPs,
......@@ -220,8 +221,6 @@ tcSimplify str local_tvs wanted_lie
(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_`
......@@ -288,7 +287,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
wanteds = filter notFunDep (lieToList wanted_lie)
given_dicts = filter isDict givens
given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
......@@ -722,7 +721,7 @@ addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
| not (isDict dict)
| not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
......@@ -1217,7 +1216,7 @@ addNoInstanceErr str givens dict
ptext SLIT("Probable cause:") <+>
vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
ptext SLIT("in") <+> str],
if isDict dict && all_tyvars then empty else
if isClassDict dict && all_tyvars then empty else
ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
where
......
......@@ -69,7 +69,7 @@ pprParendKind = pprParendType
pprPred :: PredType -> SDoc
pprPred (Class clas tys) = pprConstraint clas tys
pprPred (IParam n ty) = ppr n <+> ppr ty
pprPred (IParam n ty) = hsep [ppr n, ptext SLIT("::"), ppr ty]
pprConstraint :: Class -> [Type] -> SDoc
pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
......@@ -189,7 +189,7 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _)
<+> ptext SLIT("=>")
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_pred (IParam n ty) = hsep [{- char '?' <> -} ppr n, text "::",
ppr_ty env tYCON_PREC ty]
ppr_ty env ctxt_prec (FunTy ty1 ty2)
......
......@@ -89,7 +89,7 @@ import Var ( TyVar, IdOrTyVar, UVar,
import VarEnv
import VarSet
import Name ( Name, NamedThing(..), mkLocalName, tidyOccName,
import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
)
import NameSet
import Class ( classTyCon, Class )
......@@ -864,7 +864,7 @@ tidyType env@(tidy_env, subst) ty
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
go_note (IPNote n) = IPNote (tidyIPName n)
tidyTypes env tys = map (tidyType env) tys
\end{code}
......@@ -888,6 +888,12 @@ tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
\begin{code}
tidyIPName :: Name -> Name
tidyIPName name
= mkLocalName (getUnique name) (getOccName name) noSrcLoc
\end{code}
%************************************************************************
%* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment