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

Misc. fixes to implicit parameters support.

ghc/compiler/basicTypes/Name.lhs

@@ -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 

ghc/compiler/hsSyn/HsExpr.lhs

@@ -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

ghc/compiler/hsSyn/HsTypes.lhs

@@ -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}

ghc/compiler/main/MkIface.lhs

@@ -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}

ghc/compiler/parser/Lex.lhs

@@ -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

ghc/compiler/parser/ParseUtil.lhs

@@ -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)

ghc/compiler/parser/Parser.y

 {-
 -----------------------------------------------------------------------------
-$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 }

ghc/compiler/rename/ParseIface.y

@@ -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

ghc/compiler/typecheck/Inst.lhs

@@ -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)

ghc/compiler/typecheck/TcBinds.lhs

@@ -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

ghc/compiler/typecheck/TcExpr.lhs

@@ -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) ->

ghc/compiler/typecheck/TcImprove.lhs

@@ -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

ghc/compiler/typecheck/TcMonoType.lhs

@@ -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)

ghc/compiler/typecheck/TcSimplify.lhs

@@ -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

ghc/compiler/types/PprType.lhs

@@ -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)

ghc/compiler/types/Type.lhs

@@ -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}
+
 
 %************************************************************************
 %*									*