[haddock @ 2003-10-20 17:19:22 by sof]

support for i-parameters + zip comprehensions

8 files changed, 146 insertions, 55 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index f1718149..87de75b5 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -112,6 +112,7 @@ ppHsType (HsForAllType (Just tvs) context htype) =
      hsep (text "forall" : map ppHsName tvs ++ text "." : 
 	   ppHsContext context : text "=>" : [ppHsType htype])
 ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
+ppHsType (HsTyIP n t)  = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
 ppHsType t = ppHsBType t
 
 ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index fc65c4a1..001aa7a2 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -467,7 +467,7 @@ doDecl summary x d instances = do_decl d
 
 
 ppTypeSig :: Bool -> HsName -> HsType -> Html
-ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
+ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppHsType ty
 
 -- -----------------------------------------------------------------------------
 -- Data & newtype declarations
@@ -566,7 +566,7 @@ ppSideBySideConstr (HsRecDecl _ nm tvs ctxt fields doc) =
 ppSideBySideField :: HsFieldDecl -> HtmlTable
 ppSideBySideField (HsFieldDecl ns ty doc) =
   declBox (hsep (punctuate comma (map (ppHsBinder False) ns))
-	   <+> toHtml "::" <+> ppHsBangType ty) <->
+	   <+> dcolon <+> ppHsBangType ty) <->
   maybeRDocBox doc
 
 {-
@@ -600,14 +600,14 @@ ppShortField :: Bool -> HsFieldDecl -> HtmlTable
 ppShortField summary (HsFieldDecl ns ty _doc) 
   = tda [theclass "recfield"] << (
 	  hsep (punctuate comma (map (ppHsBinder summary) ns))
-	    <+> toHtml "::" <+> ppHsBangType ty
+	    <+> dcolon <+> ppHsBangType ty
    )
 
 {-
 ppFullField :: HsFieldDecl -> Html
 ppFullField (HsFieldDecl [n] ty doc) 
   = declWithDoc False doc (
-	ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty
+	ppHsBinder False n <+> dcolon <+> ppHsBangType ty
     )
 ppFullField _ = error "ppFullField"
 
@@ -737,11 +737,11 @@ ppFunSig summary nm ty0 doc
 	  = (declBox (
 		leader <+> 
 		hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."]) <+>
-		ppHsContext ctxt)
+		ppHsIPContext ctxt)
 	      <-> rdocBox noHtml) </> 
 	    do_args darrow ty
 	do_args leader (HsForAllType Nothing ctxt ty)
-	  = (declBox (leader <+> ppHsContext ctxt)
+	  = (declBox (leader <+> ppHsIPContext ctxt)
 		<-> rdocBox noHtml) </> 
 	    do_args darrow ty
 	do_args leader (HsTyFun (HsTyDoc ty doc0) r)
@@ -758,27 +758,37 @@ ppFunSig summary nm ty0 doc
 -- ----------------------------------------------------------------------------
 -- Types and contexts
 
-ppHsAsst	    :: HsAsst -> Html
-ppHsAsst (c,args)   =  ppHsQName c <+> hsep (map ppHsAType args)
+ppHsAsst	  :: HsAsst -> Html
+ppHsAsst (c,args) =  ppHsQName c <+> hsep (map ppHsAType args)
 
-ppHsContext	    :: HsContext -> Html
+ppHsContext	  :: HsContext -> Html
 ppHsContext []      =  empty
-ppHsContext [asst]  =  ppHsAsst asst
+ppHsContext [ctxt]  =  ppHsAsst ctxt
 ppHsContext context =  parenList (map ppHsAsst context)
 
-ppHsForAll :: Maybe [HsName] -> HsContext -> Html
+ppHsCtxt :: HsCtxt -> Html
+ppHsCtxt (HsAssump asst) = ppHsAsst asst
+ppHsCtxt (HsIP n t)      = toHtml "?" +++ ppHsName n <+> dcolon <+> ppHsType t
+
+ppHsIPContext	      :: HsIPContext -> Html
+ppHsIPContext []      =  empty
+ppHsIPContext [ctxt]  =  ppHsCtxt ctxt
+ppHsIPContext context =  parenList (map ppHsCtxt context)
+
+ppHsForAll :: Maybe [HsName] -> HsIPContext -> Html
 ppHsForAll Nothing context = 
-  hsep [ ppHsContext context, darrow ]
+  hsep [ ppHsIPContext context, darrow ]
 ppHsForAll (Just tvs) [] = 
   hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."])
 ppHsForAll (Just tvs) context =
   hsep (keyword "forall" : map ppHsName tvs ++ 
-	  [toHtml ".", ppHsContext context, darrow])
+	  [toHtml ".", ppHsIPContext context, darrow])
 
 ppHsType :: HsType -> Html
 ppHsType (HsForAllType maybe_tvs context htype) =
   ppHsForAll maybe_tvs context <+> ppHsType htype
 ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
+ppHsType (HsTyIP n t)  = toHtml "?" +++ ppHsName n <+> dcolon <+> ppHsType t
 ppHsType t = ppHsBType t
 
 ppHsBType :: HsType -> Html
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 994bf500..ef32ae80 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -151,6 +151,12 @@ renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
 renameContext :: HsContext -> RnM HsContext
 renameContext = mapM renamePred
 
+renameIPContext :: HsIPContext -> RnM HsIPContext
+renameIPContext cs = mapM renameCtxt cs
+ where
+   renameCtxt (HsIP n t)   = liftM (HsIP n) (renameType t)
+   renameCtxt (HsAssump c) = liftM HsAssump (renamePred c)
+
 renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType])
 renamePred (c,tys0) = do
   tys <- mapM renameType tys0
@@ -158,13 +164,16 @@ renamePred (c,tys0) = do
 
 renameType :: HsType -> RnM HsType
 renameType (HsForAllType tvs ctx0 ty0) = do
-  ctx <- mapM renamePred ctx0
+  ctx <- renameIPContext ctx0
   ty <- renameType ty0
   return (HsForAllType tvs ctx ty)
 renameType (HsTyFun arg0 res0) = do
   arg <- renameType arg0
   res <- renameType res0
   return (HsTyFun arg res)
+renameType (HsTyIP n ty0) = do
+  ty <- renameType ty0
+  return (HsTyIP n ty0)
 renameType (HsTyTuple b tys0) = do
   tys <- mapM renameType tys0
   return (HsTyTuple b tys)
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index ddb6afc1..4202a406 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.13 2003/08/18 10:04:47 simonmar Exp $
+-- $Id: HsLexer.lhs,v 1.14 2003/10/20 17:19:22 sof Exp $
 --
 -- (c) The GHC Team, 1997-2000
 --
@@ -26,6 +26,7 @@ import Char
 \begin{code}
 data Token 
         = VarId String
+	| IPVarId String
         | QVarId (String,String)
 	| ConId String
         | QConId (String,String)
@@ -186,6 +187,9 @@ isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'
 isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"
 isWhite  c = elem c " \n\r\t\v\f"
 
+isIdentInitial :: Char -> Bool
+isIdentInitial ch = isLower ch || ch == '_'
+
 tAB_LENGTH :: Int
 tAB_LENGTH = 8
 
@@ -307,6 +311,8 @@ lexToken cont s0 loc y x =
 						-- pop context on '}'
                                []       -> error "Internal error: empty context in lexToken"
 
+        '?':s:ss  
+	  | isIdentInitial s -> lexToken ( \ (VarId x) -> cont (IPVarId x)) (s:ss) loc y x
         '\'':s -> lexChar cont s loc y (x+1)
         '\"':s{-"-} -> lexString cont s loc y (x+1)
 
@@ -321,7 +327,7 @@ lexToken cont s0 loc y x =
 	   in
 	   afterNum cont i rest loc y (x+length num)
 
-        c:s | isLower c || c == '_' ->
+        c:s | isIdentInitial c ->
         	let 
         	    (idtail, rest) = slurpIdent s
         	    id0 = c:idtail
@@ -449,7 +455,7 @@ lexCon qual cont s0 loc y x =
   in
   case rest of
     '.':c1:s1 
-     | isLower c1 ->	-- qualified varid?
+     | isIdentInitial c1 ->	-- qualified varid?
 	let
 	    (idtail, rest1) = slurpIdent s1
 	    id0 = c1:idtail
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index de4a2562..5498cfd3 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: HsParseUtils.lhs,v 1.5 2002/07/24 09:42:18 simonmar Exp $
+-- $Id: HsParseUtils.lhs,v 1.6 2003/10/20 17:19:23 sof Exp $
 --
 -- (c) The GHC Team 1997-2000
 --
@@ -15,7 +15,8 @@ module HsParseUtils (
 	, splitTyConApp		-- HsType -> P (HsName,[HsType])
 	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
 	, checkPrec 		-- String -> P String
-	, checkContext		-- HsType -> P HsContext
+	, checkContext		-- HsType -> P HsIPContext
+	, checkIPContext        -- HsIPContext -> P HsContext
 	, checkAssertion	-- HsType -> P HsAsst
 	, checkInstHeader	-- HsType -> P (HsContext, HsAsst)
 	, checkClassHeader	-- HsType -> P (HsContext, HsName, [HsType])
@@ -36,6 +37,7 @@ import HsSyn
 import HsParseMonad
 
 import Char(isDigit,isOctDigit,isHexDigit,digitToInt)
+import List(partition)
 import Ratio
 \end{code}
 
@@ -57,13 +59,26 @@ splitTyConApp t0 = split t0 []
 -----------------------------------------------------------------------------
 -- Various Syntactic Checks
 
-checkContext :: HsType -> P HsContext
-checkContext (HsTyTuple True ts) = 
-     mapP checkAssertion ts `thenP` \cs ->
-     returnP cs
+checkContext :: HsType -> P HsIPContext
+checkContext (HsTyTuple True ts) = mapP checkCtxt ts
+  where
+   checkCtxt (HsTyIP n ty) = returnP (HsIP n ty)
+   checkCtxt t0 = 
+      checkAssertion t0 `thenP` \ c ->
+      returnP (HsAssump c)
+checkContext (HsTyIP n t) = returnP [HsIP n t]
 checkContext t = 
      checkAssertion t `thenP` \c ->
-     returnP [c]
+     returnP [HsAssump c]
+
+checkIPContext :: HsIPContext -> P HsContext
+checkIPContext ls = 
+  case partition isIP ls of
+   ([],cs) -> returnP (map (\ (HsAssump c) -> c) cs)
+   (_,_)   -> parseError "Unexpected implicit parameter in context"
+ where
+  isIP HsIP{} = True
+  isIP _      = False
 
 -- Changed for multi-parameter type classes
 
@@ -75,8 +90,9 @@ checkAssertion = checkAssertion' []
 
 checkInstHeader :: HsType -> P (HsContext, HsAsst)
 checkInstHeader (HsForAllType Nothing ctxt ty) =
-  checkAssertion ty `thenP` \asst ->
-  returnP (ctxt, asst)
+  checkAssertion ty   `thenP` \asst ->
+  checkIPContext ctxt `thenP` \ctxt' ->
+  returnP (ctxt', asst)
 checkInstHeader ty =
   checkAssertion ty `thenP` \asst ->
   returnP ([], asst)
@@ -84,7 +100,8 @@ checkInstHeader ty =
 checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])
 checkDataHeader (HsForAllType Nothing cs t) =
 	checkSimple "data/newtype" t [] `thenP` \(c,ts) ->
-	returnP (cs,c,ts)
+        checkIPContext cs `thenP` \cs' ->
+	returnP (cs',c,ts)
 checkDataHeader ty =
 	checkSimple "data/newtype" ty [] `thenP` \(c,ts) ->
 	returnP ([],c,ts)
@@ -92,7 +109,8 @@ checkDataHeader ty =
 checkClassHeader :: HsType -> P (HsContext,HsName,[HsName])
 checkClassHeader (HsForAllType Nothing cs t) = 
 	checkSimple "class" t [] `thenP` \(c,ts) ->
-	returnP (cs,c,ts)
+        checkIPContext cs        `thenP` \cs' ->
+	returnP (cs',c,ts)
 checkClassHeader ty = 
 	checkSimple "class" ty [] `thenP` \(c,ts) ->
 	returnP ([],c,ts)
@@ -157,6 +175,7 @@ patFail = parseError "Parse error in pattern"
 checkExpr :: HsExp -> P HsExp
 checkExpr e0 = case e0 of
 	HsVar _			  -> returnP e0
+	HsIPVar _                 -> returnP e0
 	HsCon _			  -> returnP e0
 	HsLit _			  -> returnP e0
 	HsInfixApp e1 e2 e3	  -> check3Exprs e1 e2 e3 HsInfixApp
@@ -229,6 +248,7 @@ checkGAlt (HsGuardedAlt loc stmts0 e0) =
 
 checkStmt :: HsStmt -> P HsStmt
 checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p)
+checkStmt (HsParStmt ss)    = mapP checkStmt ss `thenP` \ ss1 -> returnP (HsParStmt ss1)
 checkStmt (HsQualifier e)   = check1Expr e HsQualifier
 checkStmt s@(HsLetStmt _)   = returnP s
 
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 6855c2ef..4adbcef5 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.18 2002/07/19 10:00:16 simonmar Exp $
+$Id: HsParser.ly,v 1.19 2003/10/20 17:19:23 sof Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2002
 
@@ -44,6 +44,7 @@ Conflicts: 3 shift/reduce
 
 > %token
 >	VARID 	 { VarId $$ }
+>       IPVARID  { IPVarId $$ }
 >	QVARID 	 { QVarId $$ }
 >	CONID	 { ConId $$ }
 >	QCONID   { QConId $$ }
@@ -407,8 +408,12 @@ Types
 >	| btype docprev			{ HsTyDoc $1 $2 }
 
 > type :: { HsType }
-> 	: btype '->' type		{ HsTyFun $1 $3 }
->	| btype				{ $1 }
+>       : ipvar '::' type1              { HsTyIP $1 $3 }
+>       | type1                         { $1 }
+
+> type1 :: { HsType }
+>       : btype				{ $1 }
+> 	| btype '->' type1		{ HsTyFun $1 $3 }
 
 > btype :: { HsType }
 >	: btype atype			{ HsTyApp $1 $2 }
@@ -450,7 +455,7 @@ C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!
 >	| context '=>' doctype		{ mkHsForAllType Nothing $1 $3 }
 >	| doctype			{ $1 }
 
-> context :: { HsContext }
+> context :: { HsIPContext }
 > 	: btype				{% checkContext $1 }
 
 > types	:: { [HsType] }
@@ -480,11 +485,11 @@ Datatype declarations
 >	: srcloc maybe_docnext forall_stuff constr_stuff maybe_docprev
 >		{ HsConDecl $1 (fst $4) $3 [] (snd $4) ($2 `mplus` $5) }
 >	| srcloc maybe_docnext forall_stuff context '=>' constr_stuff maybe_docprev
->		{ HsConDecl $1 (fst $6) $3 $4 (snd $6) ($2 `mplus` $7) }
+>		{% checkIPContext $4 `thenP` \ ctxt -> returnP (HsConDecl $1 (fst $6) $3 ctxt (snd $6) ($2 `mplus` $7)) }
 > 	| srcloc maybe_docnext forall_stuff con '{' fielddecls '}' maybe_docprev
 > 		{ HsRecDecl $1 $4 $3 [] $6 ($2 `mplus` $8) }
 > 	| srcloc maybe_docnext forall_stuff context '=>' con '{' fielddecls '}' maybe_docprev
-> 		{ HsRecDecl $1 $6 $3 $4 $8 ($2 `mplus` $10) }
+> 		{% checkIPContext $4 `thenP` \ ctxt -> returnP (HsRecDecl $1 $6 $3 ctxt $8 ($2 `mplus` $10)) }
 
 > forall_stuff :: { [HsName] }
 > 	: 'forall' tyvars '.'		 	{ $2 }
@@ -562,6 +567,24 @@ Class declarations
 >	: 'where' decllist		{ $2 }
 >	| {- empty -}			{ [] }
 
+> dbinds :: { [HsDecl] }
+> 	 : dbinds ';' dbind		{ $3 : $1 }
+> 	 | dbinds ';'			{ $1 }
+> 	 | dbind			{ [$1] }
+> 
+> dbind	:: { HsDecl }
+> dbind	: ipvar '=' srcloc exp		{% checkValDef ($3, HsVar (UnQual $1), HsUnGuardedRhs $4, []) }
+
+> binds	::  { [HsDecl] }
+>	: decllist			{ $1 }
+>	| '{'            dbinds '}'	{ $2 }
+> 	|     layout_on  dbinds close	{ $2 }
+
+
+> wherebinds :: { [HsDecl] }
+>	: 'where' binds			{ $2 }
+>	| {- empty -}			{ [] }
+
 -----------------------------------------------------------------------------
 Instance declarations
 
@@ -580,14 +603,13 @@ Instance declarations
 Value definitions
 
 > valdef :: { HsDecl }
->	: exp0b srcloc rhs		{% checkValDef ($2, $1, $3, [])}
->	| exp0b srcloc rhs 'where' decllist
->					{% checkValDef ($2, $1, $3, $5)}
+>	: exp0b srcloc rhs 
+>					{% checkValDef ($2, $1, $3, [])}
 
 > rhs	:: { HsRhs }
->	: '=' exp			{% checkExpr $2 `thenP` \e ->
+>	: '=' exp wherebinds		{% checkExpr $2 `thenP` \e ->
 >					   returnP (HsUnGuardedRhs e) }
->	| gdrhs				{ HsGuardedRhss  (reverse $1) }
+>	| gdrhs	wherebinds		{ HsGuardedRhss  (reverse $1) }
 
 > gdrhs :: { [HsGuardedRhs] }
 >	: gdrhs gdrh			{ $2 : $1 }
@@ -628,7 +650,7 @@ the exp0 productions to distinguish these from the others (exp0a).
 > exp10a :: { HsExp }
 >	: '\\' aexps '->' exp		{% checkPatterns (reverse $2) `thenP` \ps ->
 >					   returnP (HsLambda ps $4) }
->  	| 'let' decllist 'in' exp	{ HsLet $2 $4 }
+>  	| 'let' binds 'in' exp	         { HsLet $2 $4 }
 >	| 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }
 
 > exp10b :: { HsExp }
@@ -667,7 +689,8 @@ different from specifying (exp0b qop).  The only consolation is that
 other implementations don't manage this either.
 
 > aexp1	:: { HsExp }
->	: qvar				{ HsVar $1 }
+>	: ipvar                         { HsIPVar (UnQual $1) }
+>       | qvar				{ HsVar $1 }
 >	| gcon				{ HsCon $1 }
 >  	| literal			{ $1 }
 >	| '(' exp ')'			{ HsParen $2 }
@@ -703,7 +726,7 @@ avoiding another shift/reduce-conflict.
 >	| exp ',' exp '..' 		{ HsEnumFromThen $1 $3 }
 >	| exp '..' exp	 		{ HsEnumFromTo $1 $3 }
 >	| exp ',' exp '..' exp		{ HsEnumFromThenTo $1 $3 $5 }
->	| exp '|' quals			{ HsListComp $1 (reverse $3) }
+>	| exp pquals			{ HsListComp $1 (reverse $2) }
 
 > lexps :: { [HsExp] }
 >	: lexps ',' exp 		{ $3 : $1 }
@@ -712,6 +735,16 @@ avoiding another shift/reduce-conflict.
 -----------------------------------------------------------------------------
 List comprehensions
 
+> pquals :: { [HsStmt] }
+>	 : pquals1			{ case $1 of
+> 					    [qs] -> qs
+> 					    qss  -> [HsParStmt (concat qss)]
+> 					}
+			
+> pquals1 :: { [[HsStmt]] }
+> 	: pquals1 '|' quals		{ $3 : $1 }
+> 	| '|' quals			{ [$2] }
+
 > quals :: { [HsStmt] }
 >	: quals ',' qual		{ $3 : $1 }
 >	| qual				{ [$1] }
@@ -719,7 +752,7 @@ List comprehensions
 > qual  :: { HsStmt }
 >	: pat '<-' exp			{ HsGenerator $1 $3 }
 >	| exp				{ HsQualifier $1 }
->  	| 'let' decllist		{ HsLetStmt $2 }
+>  	| 'let' binds   		{ HsLetStmt $2 }
 
 -----------------------------------------------------------------------------
 Case alternatives
@@ -734,9 +767,8 @@ Case alternatives
 >	| alt				{ [$1] }
 
 > alt :: { HsAlt }
->	: pat srcloc ralt		{ HsAlt $2 $1 $3 [] }
->	| pat srcloc ralt 'where' decllist
->				 	{ HsAlt $2 $1 $3 $5 }
+>	: pat srcloc ralt wherebinds
+>				 	{ HsAlt $2 $1 $3 $4 }
 
 > ralt :: { HsGuardedAlts }
 >	: '->' exp			{ HsUnGuardedAlt $2 }
@@ -803,6 +835,9 @@ Variables, Constructors and Operators.
 >	: conid			{ $1 }
 >	| '(' consym ')'        { $2 }
 
+> ipvar :: { HsName }
+>       : IPVARID               { HsVarName (HsIdent $1) }
+
 > qcon	:: { HsQName }
 >	: qconid		{ $1 }
 >	| '(' qconsym ')'	{ $2 }
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 511dfd54..139ef327 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.17 2003/05/06 10:04:47 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.18 2003/10/20 17:19:23 sof Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -14,7 +14,7 @@ module HsSyn (
     HsImportDecl(..), HsImportSpec(..), HsAssoc(..),
     HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..), 
     HsBangType(..), HsRhs(..),
-    HsGuardedRhs(..), HsType(..), HsContext, HsAsst,
+    HsGuardedRhs(..), HsType(..), HsContext, HsAsst, HsIPContext, HsCtxt(..),
     HsLiteral(..), HsExp(..), HsPat(..), HsPatField(..), HsStmt(..),
     HsFieldUpdate(..), HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..),
     HsCallConv(..), HsFISafety(..), HsFunDep,
@@ -194,18 +194,26 @@ data HsGuardedRhs
   deriving (Eq,Show)
 
 data HsType
-	 = HsForAllType (Maybe [HsName]) HsContext HsType
+	 = HsForAllType (Maybe [HsName]) HsIPContext HsType
 	 | HsTyFun   HsType HsType
 	 | HsTyTuple Bool{-boxed-} [HsType]
 	 | HsTyApp   HsType HsType
 	 | HsTyVar   HsName
 	 | HsTyCon   HsQName
 	 | HsTyDoc   HsType Doc
+	 | HsTyIP    HsName HsType
   deriving (Eq,Show)
 
-type HsFunDep  = ([HsName], [HsName])
-type HsContext = [HsAsst]
-type HsAsst    = (HsQName,[HsType])	-- for multi-parameter type classes
+type HsFunDep    = ([HsName], [HsName])
+type HsContext   = [HsAsst]
+type HsIPContext = [HsCtxt]
+
+data HsCtxt
+ = HsAssump HsAsst	-- for multi-parameter type classes
+ | HsIP     HsName HsType
+  deriving (Eq,Show)
+
+type HsAsst = (HsQName,[HsType])
 
 data HsLiteral
 	= HsInt		Integer
@@ -221,7 +229,8 @@ data HsLiteral
   deriving (Eq, Show)
 
 data HsExp
-	= HsVar HsQName
+	= HsIPVar HsQName
+	| HsVar HsQName
 	| HsCon HsQName
 	| HsLit HsLiteral
 	| HsInfixApp HsExp HsExp HsExp
@@ -274,6 +283,7 @@ data HsPatField
 
 data HsStmt
 	= HsGenerator HsPat HsExp
+	| HsParStmt [HsStmt]
 	| HsQualifier HsExp
 	| HsLetStmt [HsDecl]
  deriving (Eq,Show)
@@ -299,7 +309,7 @@ data HsGuardedAlt
 -- Smart constructors
 
 -- pinched from GHC
-mkHsForAllType :: Maybe [HsName] -> [HsAsst] -> HsType -> HsType
+mkHsForAllType :: Maybe [HsName] -> HsIPContext -> HsType -> HsType
 mkHsForAllType (Just []) [] ty = ty	-- Explicit for-all with no tyvars
 mkHsForAllType mtvs1     [] (HsForAllType mtvs2 ctxt ty)
  = mkHsForAllType (mtvs1 `plus` mtvs2) ctxt ty
diff --git a/src/Main.hs b/src/Main.hs
index 3e4afca2..c600f0b3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -619,7 +619,7 @@ extractClassDecl c mdl tvs0 (HsTypeSig loc [n] ty doc)
 	_ -> 
 	  HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc
  where
-  ctxt = [(Qual mdl c, map HsTyVar tvs0)]
+  ctxt = [HsAssump (Qual mdl c, map HsTyVar tvs0)]
 extractClassDecl _ _ _ d =
      error $ "Main.extractClassDecl: unexpected decl: " ++ show d