diff options
author | David Waern <david.waern@gmail.com> | 2011-11-06 00:01:47 +0100 |
---|---|---|
committer | David Waern <david.waern@gmail.com> | 2011-11-06 00:01:47 +0100 |
commit | 2d0c63d4155fde1b5d8f51b66aa2393f265eaa7b (patch) | |
tree | 074f93a78bd3059e80cbfb1f1cd29aa5b960d340 /src | |
parent | 0a8d2696f88e0308fd689475ce2896b6ba014694 (diff) | |
parent | 2deba11b49ed5ca29e947e875349f870310d3746 (diff) |
Merge branch 'master' of http://darcs.haskell.org/haddock
Diffstat (limited to 'src')
-rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 8 | ||||
-rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 37 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 38 | ||||
-rw-r--r-- | src/Haddock/Convert.hs | 85 | ||||
-rw-r--r-- | src/Haddock/GhcUtils.hs | 4 | ||||
-rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 4 | ||||
-rw-r--r-- | src/Haddock/Interface/ExtractFnArgDocs.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 44 | ||||
-rw-r--r-- | src/Haddock/InterfaceFile.hs | 55 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 2 | ||||
-rw-r--r-- | src/Main.hs | 4 |
12 files changed, 135 insertions, 150 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 44e83d64..45399963 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -114,8 +114,8 @@ ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d f (TyClD d@TySynonym{}) = ppSynonym d - f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ - f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ + f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig f _ = [] ppExport _ = [] @@ -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..c1f3a89a 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 ) @@ -114,7 +114,7 @@ tyvarNames = map (getName . hsTyVarName . unLoc) ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual = ppFunSig summary links loc doc [name] typ unicode qual ppFor _ _ _ _ _ _ _ = error "ppFor" @@ -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/GhcUtils.hs b/src/Haddock/GhcUtils.hs index f79acd94..33ae1b6d 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -96,8 +96,8 @@ getMainDeclBinder (ValD d) = #endif getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _)) = [] +getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] +getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Useful when there is a signature with multiple names, e.g. 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..057fceb7 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -263,7 +263,7 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats declNames :: HsDecl a -> [a] declNames (TyClD d) = [tcdName d] -declNames (ForD (ForeignImport n _ _)) = [unLoc n] +declNames (ForD (ForeignImport n _ _ _)) = [unLoc n] -- we have normal sigs only (since they are taken from ValBindsOut) declNames (SigD sig) = sigNameNoLoc sig declNames _ = error "unexpected argument to declNames" @@ -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/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs index 8889c3ab..a9f8a807 100644 --- a/src/Haddock/Interface/ExtractFnArgDocs.hs +++ b/src/Haddock/Interface/ExtractFnArgDocs.hs @@ -24,7 +24,7 @@ import GHC getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty -getDeclFnArgDocs (ForD (ForeignImport _ ty _)) = getTypeFnArgDocs ty +getDeclFnArgDocs (ForD (ForeignImport _ ty _ _)) = getTypeFnArgDocs ty getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty getDeclFnArgDocs _ = Map.empty diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 2d5c899a..546ba62b 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 @@ -410,14 +392,14 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) -renameForD (ForeignImport lname ltype x) = do +renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignImport lname' ltype' x) -renameForD (ForeignExport lname ltype x) = do + return (ForeignImport lname' ltype' co x) +renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype - return (ForeignExport lname' ltype' x) + return (ForeignExport lname' ltype' co x) renameInstD :: InstDecl Name -> RnM (InstDecl DocName) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 1c2aa360..24c1bc92 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -30,6 +31,7 @@ import Data.Map (Map) import GHC hiding (NoLink) import Binary +import BinIface (getSymtabName, getDictFastString) import Name import UniqSupply import UniqFM @@ -104,10 +106,10 @@ writeInterfaceFile filename iface = do let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, bin_dict_map = dict_map_ref } - ud <- newWriteState (putName bin_symtab) (putFastString bin_dict) -- put the main thing - bh <- return $ setUserData bh0 ud + bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file @@ -166,9 +168,11 @@ freshNameCache = ( create_fresh_nc , \_ -> return () ) -- monad being used. The exact monad is whichever monad the first -- argument, the getter and setter of the name cache, requires. -- -readInterfaceFile :: MonadIO m => - NameCacheAccessor m - -> FilePath -> m (Either String InterfaceFile) +readInterfaceFile :: forall m. + MonadIO m + => NameCacheAccessor m + -> FilePath + -> m (Either String InterfaceFile) readInterfaceFile (get_name_cache, set_name_cache) filename = do bh0 <- liftIO $ readBinMem filename @@ -180,23 +184,38 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do "Magic number mismatch: couldn't load interface file: " ++ filename | version /= binaryInterfaceVersion -> return . Left $ "Interface file is of wrong version: " ++ filename - | otherwise -> do + | otherwise -> with_name_cache $ \update_nc -> do dict <- get_dictionary bh0 - bh1 <- init_handle_user_data bh0 dict - - theNC <- get_name_cache - (nc', symtab) <- get_symbol_table bh1 theNC - set_name_cache nc' - - -- set the symbol table - let ud' = getUserData bh1 - bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab} + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- update_nc (get_symbol_table bh1) + return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) + (getDictFastString dict) -- load the actual data - iface <- liftIO $ get bh2 + iface <- liftIO $ get bh1 return (Right iface) where + with_name_cache :: forall a. + ((forall n b. MonadIO n + => (NameCache -> n (NameCache, b)) + -> n b) + -> m a) + -> m a + with_name_cache act = do + nc_var <- get_name_cache >>= (liftIO . newIORef) + x <- act $ \f -> do + nc <- liftIO $ readIORef nc_var + (nc', x) <- f nc + liftIO $ writeIORef nc_var nc' + return x + liftIO (readIORef nc_var) >>= set_name_cache + return x + get_dictionary bin_handle = liftIO $ do dict_p <- get bin_handle data_p <- tellBin bin_handle @@ -205,10 +224,6 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do seekBin bin_handle data_p return dict - init_handle_user_data bin_handle dict = liftIO $ do - ud <- newReadState dict - return (setUserData bin_handle ud) - get_symbol_table bh1 theNC = liftIO $ do symtab_p <- get bh1 data_p' <- tellBin bh1 diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index c0bf4ad7..c9b29bd0 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]) ----------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index c8b17a0c..cc5d1302 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -60,6 +60,8 @@ import DynFlags hiding (flags, verbosity) import Panic (panic, handleGhcException) import Module +import Control.Monad.Fix (MonadFix) + -------------------------------------------------------------------------------- -- * Exception handling @@ -251,7 +253,7 @@ render flags ifaces installedIfaces srcMap = do ------------------------------------------------------------------------------- -readInterfaceFiles :: MonadIO m => +readInterfaceFiles :: (MonadFix m, MonadIO m) => NameCacheAccessor m -> [(DocPaths, FilePath)] -> m [(DocPaths, InterfaceFile)] |