aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDB.hs1
-rw-r--r--src/HaddockHtml.hs36
-rw-r--r--src/HaddockRename.hs11
-rw-r--r--src/HsLexer.lhs12
-rw-r--r--src/HsParseUtils.lhs42
-rw-r--r--src/HsParser.ly71
-rw-r--r--src/HsSyn.lhs26
-rw-r--r--src/Main.hs2
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:52:25 +0000