aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Backends/Hoogle.hs4
-rw-r--r--src/Haddock/Backends/LaTeX.hs37
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs36
-rw-r--r--src/Haddock/Convert.hs85
-rw-r--r--src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--src/Haddock/Interface/Create.hs2
-rw-r--r--src/Haddock/Interface/Rename.hs36
-rw-r--r--src/Haddock/Lex.x34
-rw-r--r--src/Haddock/Types.hs2
9 files changed, 118 insertions, 120 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 44e83d64..adf95636 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -143,10 +143,10 @@ ppClass x = out x{tcdSigs=[]} :
addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
addContext _ = error "expected TypeSig"
- f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d
+ f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
f t = HsForAllTy Implicit [] (reL [context]) (reL t)
- context = reL $ HsClassP (unL $ tcdLName x)
+ context = nlHsTyConApp (unL $ tcdLName x)
(map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 27f6bd5e..d6a71f27 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import GHC
import OccName
import Name ( isTyConName, nameOccName )
import RdrName ( rdrNameOcc, isRdrTc )
-import BasicTypes ( IPName(..), Boxity(..) )
+import BasicTypes ( ipNameName )
import Outputable ( Outputable, ppr, showSDoc )
import FastString ( unpackFS, unpackLitString )
@@ -450,7 +450,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
@@ -473,7 +473,7 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> LaTeX
ppClassDecl instances loc mbDoc subdocs
- (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+ (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode
= declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
instancesBit
where
@@ -486,8 +486,8 @@ ppClassDecl instances loc mbDoc subdocs
body = catMaybes [fmap docToLaTeX mbDoc, body_]
body_
- | null lsigs, null ats = Nothing
- | null ats = Just methodTable
+ | null lsigs, null ats, null at_defs = Nothing
+ | null ats, null at_defs = Just methodTable
--- | otherwise = atTable $$ methodTable
| otherwise = error "LaTeX.ppClassDecl"
@@ -771,7 +771,7 @@ ppContextNoArrow [] _ = empty
ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
-ppContextNoLocs :: [HsPred DocName] -> Bool -> LaTeX
+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
ppContextNoLocs [] _ = empty
ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
@@ -780,17 +780,10 @@ ppContext :: HsContext DocName -> Bool -> LaTeX
ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
-pp_hs_context :: [HsPred DocName] -> Bool -> LaTeX
+pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
pp_hs_context [] _ = empty
-pp_hs_context [p] unicode = ppPred unicode p
-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
-
-
-ppPred :: Bool -> HsPred DocName -> LaTeX
-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2
-ppPred unicode (HsIParam (IPName n) t)
- = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t
+pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
-------------------------------------------------------------------------------
@@ -807,9 +800,9 @@ ppBang HsNoBang = empty
ppBang _ = char '!' -- Unpacked args is an implementation detail,
-tupleParens :: Boxity -> [LaTeX] -> LaTeX
-tupleParens Boxed = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple = ubxParenList
-------------------------------------------------------------------------------
@@ -878,12 +871,16 @@ ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t
ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)
+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
+
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index add926ab..28132046 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,9 +32,9 @@ import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
-import BasicTypes ( IPName(..), Boxity(..) )
import GHC
import Name
+import BasicTypes ( ipNameName )
import Outputable ( ppr, showSDoc, Outputable )
@@ -301,7 +301,7 @@ ppContextNoArrow [] _ _ = noHtml
ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
-ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
ppContextNoLocs [] _ _ = noHtml
ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual
<+> darrow unicode
@@ -311,18 +311,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html
+pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
pp_hs_context [] _ _ = noHtml
-pp_hs_context [p] unicode qual = ppPred unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt)
-
-
-ppPred :: Bool -> Qualification -> HsPred DocName -> Html
-ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual
-ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"
- <+> ppLType unicode qual t2
-ppPred unicode qual (HsIParam (IPName n) t)
- = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t
+pp_hs_context [p] unicode qual = ppType unicode qual p
+pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
-------------------------------------------------------------------------------
@@ -330,7 +322,7 @@ ppPred unicode qual (HsIParam (IPName n) t)
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
-> Bool -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
@@ -352,7 +344,7 @@ ppFds fds unicode qual =
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
-> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
-> Html
-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc
subdocs unicode qual =
if null sigs && null ats
then (if summary then id else topDeclElem links loc [nm]) hdr
@@ -381,7 +373,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
-> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> Qualification -> Html
ppClassDecl summary links instances loc mbDoc subdocs
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs unicode qual
| otherwise = classheader +++ maybeDocSection qual mbDoc
+++ atBit +++ methodBit +++ instancesBit
@@ -653,9 +645,9 @@ ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
-- so we just show the strictness annotation
-tupleParens :: Boxity -> [Html] -> Html
-tupleParens Boxed = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple = ubxParenList
--------------------------------------------------------------------------------
@@ -724,7 +716,7 @@ ppr_mono_ty _ (HsKindSig ty kind) u q =
parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)
+ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
#if __GLASGOW_HASKELL__ == 612
ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
@@ -734,6 +726,10 @@ ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteT
ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 34de6775..e46a37a4 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,14 +20,16 @@ module Haddock.Convert where
import HsSyn
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
import TypeRep
+import Kind ( liftedTypeKind, constraintKind )
import Coercion ( splitKindFunTys, synTyConResKind )
import Name
import Var
import Class
import TyCon
import DataCon
+import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName )
+import TysWiredIn ( listTyConName, eqTyCon )
import Bag ( emptyBag )
import SrcLoc ( Located, noLoc, unLoc )
@@ -47,7 +49,24 @@ tyThingToLHsDecl t = noLoc $ case t of
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
- ATyCon tc -> TyClD (synifyTyCon tc)
+ ATyCon tc
+ | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
+ -> TyClD $ ClassDecl
+ (synifyCtx (classSCTheta cl))
+ (synifyName cl)
+ (synifyTyVars (classTyVars cl))
+ (map (\ (l,r) -> noLoc
+ (map getName l, map getName r) ) $
+ snd $ classTvsFds cl)
+ (map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+ (classMethods cl))
+ emptyBag --ignore default method definitions, they don't affect signature
+ -- class associated-types are a subset of TyCon:
+ [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]
+ [] --ignore associated type defaults
+ [] --we don't have any docs at this point
+ | otherwise
+ -> TyClD (synifyTyCon tc)
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
@@ -56,26 +75,10 @@ tyThingToLHsDecl t = noLoc $ case t of
-- a data-constructor alone just gets rendered as a function:
ADataCon dc -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
- -- classes are just a little tedious
- AClass cl ->
- TyClD $ ClassDecl
- (synifyCtx (classSCTheta cl))
- (synifyName cl)
- (synifyTyVars (classTyVars cl))
- (map (\ (l,r) -> noLoc
- (map getName l, map getName r) ) $
- snd $ classTvsFds cl)
- (map (noLoc . synifyIdSig DeleteTopLevelQuantification)
- (classMethods cl))
- emptyBag --ignore default method definitions, they don't affect signature
- (map synifyClassAT (classATs cl))
- [] --we don't have any docs at this point
-
--- class associated-types are a subset of TyCon
--- (mainly only type/data-families)
-synifyClassAT :: TyCon -> LTyClDecl Name
-synifyClassAT = noLoc . synifyTyCon
+synifyATDefault :: TyCon -> LTyClDecl Name
+synifyATDefault tc = noLoc (synifyAxiom ax)
+ where Just ax = tyConFamilyCoercion_maybe tc
synifyAxiom :: CoAxiom -> TyClDecl Name
synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
@@ -224,25 +227,7 @@ synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
synifyCtx :: [PredType] -> LHsContext Name
-synifyCtx = noLoc . map synifyPred
-
-
-synifyPred :: PredType -> LHsPred Name
-synifyPred (ClassP cls tys) =
- let sTys = map (synifyType WithinType) tys
- in noLoc $
- HsClassP (getName cls) sTys
-synifyPred (IParam ip ty) =
- let sTy = synifyType WithinType ty
- -- IPName should be in class NamedThing...
- in noLoc $
- HsIParam ip sTy
-synifyPred (EqPred ty1 ty2) =
- let
- s1 = synifyType WithinType ty1
- s2 = synifyType WithinType ty2
- in noLoc $
- HsEqualP s1 s2
+synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
@@ -273,16 +258,26 @@ data SynifyTypeState
synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (PredTy{}) = --should never happen.
- error "synifyType: PredTys are not, in themselves, source-level types."
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
synifyType _ (TyConApp tc tys)
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| isTupleTyCon tc, tyConArity tc == length tys =
- noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)
+ noLoc $ HsTupleTy (case tupleTyConSort tc of
+ BoxedTuple -> HsBoxyTuple liftedTypeKind
+ ConstraintTuple -> HsBoxyTuple constraintKind
+ UnboxedTuple -> HsUnboxedTuple)
+ (map (synifyType WithinType) tys)
-- ditto for lists
| getName tc == listTyConName, [ty] <- tys =
noLoc $ HsListTy (synifyType WithinType ty)
+ -- ditto for implicit parameter tycons
+ | Just ip <- tyConIP_maybe tc
+ , [ty] <- tys
+ = noLoc $ HsIParamTy ip (synifyType WithinType ty)
+ -- and equalities
+ | tc == eqTyCon
+ , [ty1, ty2] <- tys
+ = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
-- Most TyCons:
| otherwise =
foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
@@ -313,9 +308,9 @@ synifyType s forallty@(ForAllTy _tv _ty) =
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
- ([HsPred Name], Name, [HsType Name])
+ ([HsType Name], Name, [HsType Name])
synifyInstHead (_, preds, cls, ts) =
- ( map (unLoc . synifyPred) preds
+ ( map (unLoc . synifyType WithinType) preds
, getName cls
, map (unLoc . synifyType WithinType) ts
)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index e4da3233..01d5b0f4 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -116,7 +116,6 @@ getAllInfo name = withSession $ \hsc_env -> do
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
--- TODO: should we support PredTy here?
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
@@ -134,7 +133,6 @@ instHead (_, _, cls, args)
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
- simplify _ = error "simplify"
-- sortImage f = sortBy (\x y -> compare (f x) (f y))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f9d72bd0..860a0044 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -770,7 +770,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
_ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
where
lctxt = noLoc . ctxt
- ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
+ ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 2d5c899a..4ea22a2e 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -17,8 +17,8 @@ import Haddock.GhcUtils
import GHC hiding (NoLink)
import Name
-import BasicTypes
import Bag (emptyBag)
+import BasicTypes ( IPName(..), ipNameName )
import Data.List
import qualified Data.Map as Map hiding ( Map )
@@ -208,25 +208,6 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
-renameLPred :: LHsPred Name -> RnM (LHsPred DocName)
-renameLPred = mapM renamePred
-
-
-renamePred :: HsPred Name -> RnM (HsPred DocName)
-renamePred (HsClassP name types) = do
- name' <- rename name
- types' <- mapM renameLType types
- return (HsClassP name' types')
-renamePred (HsEqualP type1 type2) = do
- type1' <- renameLType type1
- type2' <- renameLType type2
- return (HsEqualP type1' type2')
-renamePred (HsIParam (IPName name) t) = do
- name' <- rename name
- t' <- renameLType t
- return (HsIParam (IPName name') t')
-
-
renameLType :: LHsType Name -> RnM (LHsType DocName)
renameLType = mapM renameType
@@ -254,6 +235,8 @@ renameType t = case t of
HsListTy ty -> return . HsListTy =<< renameLType ty
HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
+ HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)
+ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
@@ -265,8 +248,6 @@ renameType t = case t of
HsParTy ty -> return . HsParTy =<< renameLType ty
- HsPredTy p -> return . HsPredTy =<< renamePred p
-
HsKindSig ty k -> do
ty' <- renameLType ty
return (HsKindSig ty' k)
@@ -285,15 +266,15 @@ renameLTyVarBndr (L loc tv) = do
return $ L loc (replaceTyVarName tv name')
-renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName])
+renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
renameLContext (L loc context) = do
- context' <- mapM renameLPred context
+ context' <- mapM renameLType context
return (L loc context')
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
renameInstHead (preds, className, types) = do
- preds' <- mapM renamePred preds
+ preds' <- mapM renameType preds
className' <- rename className
types' <- mapM renameType types
return (preds', className', types')
@@ -351,15 +332,16 @@ renameTyClD d = case d of
typats' <- mapM (mapM renameLType) typats
return (TySynonym lname' ltyvars' typats' ltype')
- ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do
+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM renameLTyClD ats
+ at_defs' <- mapM renameLTyClD at_defs
-- we don't need the default methods or the already collected doc entities
- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])
+ return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])
where
renameLCon (L loc con) = return . L loc =<< renameCon con
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 17267656..e41c9461 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -31,12 +31,11 @@ import DynFlags
import FastString
import Data.Char
+import Data.Word (Word8)
import Numeric
import System.IO.Unsafe
}
-%wrapper "posn"
-
$ws = $white # \n
$digit = [0-9]
$hexdigit = [0-9a-fA-F]
@@ -140,6 +139,37 @@ tokenPos t = let AlexPn _ line col = snd t in (line, col)
-- -----------------------------------------------------------------------------
-- Alex support stuff
+-- XXX: copied the posn wrapper code from Alex to make this lexer work
+-- with both Alex 2.x and Alex 3.x. However, we are not using the
+-- Unicode/UTF-8 support in Alex 3.x, and Unicode documentation will
+-- probably get mangled.
+
+type AlexInput = (AlexPosn, -- current position,
+ Char, -- previous char
+ String) -- current input string
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p,c,s) = c
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (p,c,[]) = Nothing
+alexGetByte (p,_,(c:s)) = let p' = alexMove p c
+ in p' `seq` Just (fromIntegral (ord c), (p', c, s))
+
+-- for compat with Alex 2.x:
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar i = case alexGetByte i of
+ Nothing -> Nothing
+ Just (b,i') -> Just (chr (fromIntegral b), i')
+
+alexMove :: AlexPosn -> Char -> AlexPosn
+alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1)
+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1
+alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1)
+
+data AlexPosn = AlexPn !Int !Int !Int
+ deriving (Eq,Show)
+
type StartCode = Int
type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken]
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index d82e3efd..fddafc1d 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -259,7 +259,7 @@ type DocInstance name = (InstHead name, Maybe (Doc name))
-- | The head of an instance. Consists of a context, a class name and a list
-- of instance types.
-type InstHead name = ([HsPred name], name, [HsType name])
+type InstHead name = ([HsType name], name, [HsType name])
-----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 22:56:49 +0000