From 187d7618e86c8db865c0cdcc38d0633c23cf1d88 Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 20 Oct 2003 17:19:24 +0000 Subject: [haddock @ 2003-10-20 17:19:22 by sof] support for i-parameters + zip comprehensions --- src/HaddockDB.hs | 1 + src/HaddockHtml.hs | 36 ++++++++++++++++---------- src/HaddockRename.hs | 11 +++++++- src/HsLexer.lhs | 12 ++++++--- src/HsParseUtils.lhs | 42 +++++++++++++++++++++++-------- src/HsParser.ly | 71 +++++++++++++++++++++++++++++++++++++++------------- src/HsSyn.lhs | 26 +++++++++++++------ src/Main.hs | 2 +- 8 files changed, 146 insertions(+), 55 deletions(-) (limited to 'src') 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 -- cgit v1.2.3