diff options
author | Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> | 2013-07-09 14:24:10 +0100 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2014-01-12 14:48:35 -0600 |
commit | bb6cef20b82ef7a7f2d49f3ef6dc1a7ce880b5f0 (patch) | |
tree | ea07b1d4ab43169bc8d7074ff05bf1792c93feb0 /src/Haddock/Backends | |
parent | c1228df0339d041b455bb993786a9ed6322c5e01 (diff) |
One pass parser and tests.
We remove the HTML test as it is no longer necessary. We cover the
test case in spec tests and other HTML tests but keeping this around
fails: this is because the new parser has different semantics there.
In fact, I suspect the original behaviour was a bug that wasn't
caught/fixed but simply included as-is during the testing.
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 47 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 15 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 7 |
3 files changed, 40 insertions, 29 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 0bc95719..64966ac2 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -33,6 +33,9 @@ import Data.Char import Control.Monad import Data.Maybe import Data.List + +import Haddock.Doc (combineDocumentation) + -- import Debug.Trace {- SAMPLE OUTPUT @@ -278,11 +281,11 @@ ppDecl :: LHsDecl DocName ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode - TyClD d@(DataDecl {}) + TyClD d@(DataDecl {}) -> ppDataDecl instances subdocs loc doc d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) +-- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode @@ -465,7 +468,7 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc doc subdocs - (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit @@ -504,7 +507,7 @@ ppDocInstances unicode (i : rest) | Just ihead <- isUndocdInstance i = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ ppDocInstances unicode rest' - | otherwise + | otherwise = ppDocInstance unicode i $$ ppDocInstances unicode rest where (is, rest') = spanWith isUndocdInstance rest @@ -650,9 +653,9 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = +-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = -- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ +-- hsep ((ppHsConstrHdr tvs ctxt +++ -- ppHsBinder False nm) : map ppHsBangType typeList) -- ) -- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = @@ -661,35 +664,35 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = -- Nothing -> aboves [hdr, fields_html] -- Just _ -> aboves [hdr, constr_doc, fields_html] -- ) --- +-- -- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc +-- +-- constr_doc -- | isJust doc = docBox (docToLaTeX (fromJust doc)) -- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << +-- +-- fields_html = +-- td << -- table ! [width "100%", cellpadding 0, cellspacing 8] << ( -- aboves (map ppFullField (concat (map expandField fields))) -- ) -- -} --- +-- -- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX -- ppShortField summary unicode (ConDeclField (L _ name) ltype _) -- = tda [theclass "recfield"] << ( -- ppBinder summary (docNameOcc name) -- <+> dcolon unicode <+> ppLType unicode ltype -- ) --- +-- -- {- -- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) +-- ppFullField (HsFieldDecl [n] ty doc) -- = declWithDoc False doc ( -- ppHsBinder False n <+> dcolon <+> ppHsBangType ty -- ) -- ppFullField _ = error "ppFullField" --- +-- -- expandField :: HsFieldDecl -> [HsFieldDecl] -- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] -- -} @@ -718,7 +721,7 @@ ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) --- | Print an application of a DocName and a list of Names +-- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns = ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName @@ -1002,7 +1005,7 @@ parLatexMarkup ppId = Markup { markupEmphasis = \p v -> emph (p v), markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \path _ -> parens (text "image: " <> text path), + markupPic = \p _ -> markupPic p, markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", @@ -1020,6 +1023,14 @@ parLatexMarkup ppId = Markup { Just label -> text "\\href" <> braces (text url) <> braces (text label) Nothing -> text "\\url" <> braces (text url) + -- Is there a better way of doing this? Just a space is an aribtrary choice. + markupPic (Picture uri title) = parens (imageText title) + where + imageText Nothing = beg + imageText (Just t) = beg <> text " " <> text t + + beg = text "image: " <> text uri + markupId ppId_ id v = case v of Verb -> theid diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 2ecc6464..91e6871d 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -25,6 +25,7 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types +import Haddock.Doc (combineDocumentation) import Data.List ( intersperse ) import qualified Data.Map as Map @@ -115,7 +116,7 @@ ppFor _ _ _ _ _ _ _ = error "ppFor" ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdRhs = ltype }) + , tcdRhs = ltype }) unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual @@ -204,12 +205,12 @@ ppAssocType summ links doc (L loc decl) unicode qual = -- * TyClDecl helpers -------------------------------------------------------------------------------- --- | Print a type family and its variables +-- | Print a type family and its variables ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) --- | Print a newtype / data binder and its variables +-- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html ppDataBinderWithVars summ decl = ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) @@ -226,7 +227,7 @@ ppAppNameTypes n ts unicode qual = ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual) --- | Print an application of a DocName and a list of Names +-- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html ppAppDocNameNames summ n ns = ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName @@ -305,7 +306,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc - subdocs unicode qual = + subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where") @@ -580,7 +581,7 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd - , dd_ctxt = ctxt } }) + , dd_ctxt = ctxt } }) unicode qual = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> @@ -723,5 +724,3 @@ ppr_fun_ty ctxt_prec ty1 ty2 unicode qual in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] - - diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index aa4ba377..31d653bc 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -18,18 +18,19 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where +import Control.Applicative ((<$>)) import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils +import Haddock.Doc (combineDocumentation) -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) import GHC - parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html parHtmlMarkup qual ppId = Markup { markupEmpty = noHtml, @@ -49,7 +50,7 @@ parHtmlMarkup qual ppId = Markup { markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", - markupPic = \path -> image ! [src path], + markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml } |