aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs5
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs19
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs1
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs32
-rw-r--r--haddock-api/src/Haddock/Types.hs9
6 files changed, 66 insertions, 3 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f1d8ddb2..fc71d4b5 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -328,7 +328,8 @@ markupTag dflags = Markup {
markupAName = const $ str "",
markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString,
- markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h
+ markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h,
+ markupTable = \(Table _ _) -> str "TODO: table"
}
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d79e0e6c..3ac3b405 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1140,7 +1140,8 @@ parLatexMarkup ppId = Markup {
markupAName = \_ _ -> empty,
markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
- markupHeader = \(Header l h) p -> header l (h p)
+ markupHeader = \(Header l h) p -> header l (h p),
+ markupTable = \(Table h b) p -> table h b p
}
where
header 1 d = text "\\section*" <> braces d
@@ -1149,6 +1150,8 @@ parLatexMarkup ppId = Markup {
| l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
+ table _ _ _ = text "{TODO: Table}"
+
fixString Plain s = latexFilter s
fixString Verb s = s
fixString Mono s = latexMonoFilter s
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e63667b0..2990e1e4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -73,7 +73,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),
markupProperty = pre . toHtml,
markupExample = examplesToHtml,
- markupHeader = \(Header l t) -> makeHeader l t
+ markupHeader = \(Header l t) -> makeHeader l t,
+ markupTable = \(Table h r) -> makeTable h r
}
where
makeHeader :: Int -> Html -> Html
@@ -85,6 +86,22 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
makeHeader 6 mkup = h6 mkup
makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+ makeTable :: [TableRow Html] -> [TableRow Html] -> Html
+ makeTable hs bs = table (concatHtml (hs' ++ bs'))
+ where
+ hs' | null hs = []
+ | otherwise = [thead (concatHtml (map (makeTableRow th) hs))]
+
+ bs' = [tbody (concatHtml (map (makeTableRow td) bs))]
+
+ makeTableRow :: (Html -> Html) -> TableRow Html -> Html
+ makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))
+
+ makeTableCell :: (Html -> Html) -> TableCell Html -> Html
+ makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')
+ where
+ i' = if i == 1 then [] else [ colspan i ]
+ j' = if j == 1 then [] else [ rowspan j ]
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 75b2f223..311301ee 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -144,6 +144,7 @@ rename dflags gre = rn
DocEmpty -> pure (DocEmpty)
DocString str -> pure (DocString str)
DocHeader (Header l t) -> DocHeader . Header l <$> rn t
+ DocTable t -> DocTable <$> traverse rn t
-- | Wrap an identifier that's out of scope (i.e. wasn't found in
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 76bcb4ae..bbd8d04e 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -459,6 +459,32 @@ instance Binary a => Binary (Header a) where
t <- get bh
return (Header l t)
+instance Binary a => Binary (Table a) where
+ put_ bh (Table h b) = do
+ put_ bh h
+ put_ bh b
+ get bh = do
+ h <- get bh
+ b <- get bh
+ return (Table h b)
+
+instance Binary a => Binary (TableRow a) where
+ put_ bh (TableRow cs) = put_ bh cs
+ get bh = do
+ cs <- get bh
+ return (TableRow cs)
+
+instance Binary a => Binary (TableCell a) where
+ put_ bh (TableCell i j c) = do
+ put_ bh i
+ put_ bh j
+ put_ bh c
+ get bh = do
+ i <- get bh
+ j <- get bh
+ c <- get bh
+ return (TableCell i j c)
+
instance Binary Meta where
put_ bh Meta { _version = v } = put_ bh v
get bh = (\v -> Meta { _version = v }) <$> get bh
@@ -542,6 +568,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
put_ bh (DocMathDisplay x) = do
putByte bh 22
put_ bh x
+ put_ bh (DocTable x) = do
+ putByte bh 23
+ put_ bh x
get bh = do
h <- getByte bh
@@ -615,6 +644,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
22 -> do
x <- get bh
return (DocMathDisplay x)
+ 23 -> do
+ x <- get bh
+ return (DocTable x)
_ -> error "invalid binary data found in the interface file"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b4cdc343..725606b2 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -454,6 +454,7 @@ instance (NFData a, NFData mod)
DocProperty a -> a `deepseq` ()
DocExamples a -> a `deepseq` ()
DocHeader a -> a `deepseq` ()
+ DocTable a -> a `deepseq` ()
#if !MIN_VERSION_ghc(8,0,2)
-- These were added to GHC itself in 8.0.2
@@ -474,6 +475,14 @@ instance NFData Picture where
instance NFData Example where
rnf (Example a b) = a `deepseq` b `deepseq` ()
+instance NFData id => NFData (Table id) where
+ rnf (Table h b) = h `deepseq` b `deepseq` ()
+
+instance NFData id => NFData (TableRow id) where
+ rnf (TableRow cs) = cs `deepseq` ()
+
+instance NFData id => NFData (TableCell id) where
+ rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` ()
exampleToString :: Example -> String
exampleToString (Example expression result) =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-27 08:43:13 +0000