diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Org')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Org/Types.hs | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Org/Types.hs b/haddock-api/src/Haddock/Backends/Org/Types.hs new file mode 100644 index 00000000..81f2add5 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Org/Types.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Haddock.Backends.Org.Types where + +import Data.Char ( isSpace ) +import Data.List ( dropWhileEnd + , intercalate + ) +import Data.Map ( Map ) +import GHC.Utils.Ppr ( ($$) + , (<+>) + , (<>) + , Doc + , Mode(..) + , brackets + , empty + , fullRender + , hang + , hcat + , hsep + , punctuate + , text + , txtPrinter + , vcat + ) +import Prelude hiding ( (<>) ) + +-- * Some consts +defListSep :: Doc +defListSep = text "::" + +unorderedBullet, orderedBullet :: String +unorderedBullet = "-" +orderedBullet = "." + +colons :: Doc -> Doc +colons doc = text ":" <> doc <> text ":" + +-- * Document, Sections and Headings + +data OrgDocument = OrgDocument + { oDKeywords :: Map String Doc + , oDBlocks :: [OrgBlock] + } + deriving Show + +-- todo: handle keywords + +type Properties = [(String, String)] + +-- * Blocks + +-- | Org block. Like a Pandoc Block. +data OrgBlock + = Heading Int [OrgInline] Properties + | PlainList ListType [[OrgBlock]] + | DefList [DefListItem] + | Paragraph [OrgInline] + | Table [[[OrgInline]]] [[[OrgInline]]] + | SrcBlock Doc + | MathDisplay Doc + | Example Doc Doc -- expression and result + deriving (Show) + +-- Lists + +data ListType = Ordered | Unordered + deriving (Show) + +type DefListItem = ([OrgInline], [OrgBlock]) + +-- * Inlines + +-- | Objects (inline elements). Derived from Pandoc's Inline. +data OrgInline + = Plain Doc + | Italic [OrgInline] + | Bold [OrgInline] + | Code Doc + | Link Doc [OrgInline] + | Anchor Doc + | Whitespace + | MathInline Doc + deriving (Show) + +-- * From Org elements to Doc + +fromOrgDocument :: OrgDocument -> Doc +fromOrgDocument (OrgDocument _ blocks) = fromOrgBlocks blocks <> text "\n" + +fromOrgBlock :: OrgBlock -> Doc +fromOrgBlock (Heading level inlines props) = hang + (text (replicate level '*') <+> fromOrgInlines inlines) + (level + 1) + (fromOrgProperties props) +fromOrgBlock (Paragraph inlines) = fromOrgInlines inlines +fromOrgBlock (SrcBlock code) = + -- The \n followed by <> code makes indentation work, given the code has no indent + vcat [text "#+begin_src haskell\n" <> code, text "#+end_src"] +fromOrgBlock (DefList defs) = vcat $ map + (\(term, def) -> fromOrgListItem + unorderedBullet + (prependInlinesToBlocks (term ++ [Whitespace, plaintext "::", Whitespace]) + def + ) + ) + defs +fromOrgBlock (PlainList Unordered items) = + vcat $ map (uncurry fromOrgListItem) (zip (repeat unorderedBullet) items) +fromOrgBlock (PlainList Ordered items) = vcat $ map + (uncurry fromOrgListItem) + (zip (map ((++ orderedBullet) . show) [1 ..]) items) +fromOrgBlock (Example expr res) = + (fromOrgBlock (SrcBlock expr)) $$ (text "#+RESULTS:") $$ res +fromOrgBlock (MathDisplay doc) = doc +fromOrgBlock (Table header body) = + vcat (map fromOrgTableRow header) $$ tableRule len $$ vcat + (map fromOrgTableRow body) + where + len = case header of + [] -> case body of + [] -> 0 + h : _ -> length h + h : _ -> length h + +tableRule :: Int -> Doc +tableRule n = + text "|" <> hcat (punctuate (text "|") (replicate n (text "-"))) <> text "|" + +fromOrgTableRow :: [[OrgInline]] -> Doc +fromOrgTableRow row = + text "|" <+> hsep (punctuate (text "|") (map fromOrgInlines row)) <+> text "|" + +prependInlinesToBlock :: [OrgInline] -> OrgBlock -> [OrgBlock] +prependInlinesToBlock [] block = [block] +prependInlinesToBlock _ (Heading _ _ _) = + error "Prepending inlines to a heading!" +prependInlinesToBlock is (Paragraph is') = [Paragraph (is ++ is')] +prependInlinesToBlock is block = [Paragraph is, block] + +prependInlinesToBlocks :: [OrgInline] -> [OrgBlock] -> [OrgBlock] +prependInlinesToBlocks is [] = [Paragraph is] +prependInlinesToBlocks is (h : t) = prependInlinesToBlock is h ++ t + +fromOrgProperties :: Properties -> Doc +fromOrgProperties props | null props = empty +fromOrgProperties props = + colons (text "PROPERTIES") + $$ vcat (map (\(prop, value) -> colons (text prop) <+> text value) props) + $$ colons (text "END") + +fromOrgBlocks :: [OrgBlock] -> Doc +fromOrgBlocks = vcat . punctuate (text "\n") . map fromOrgBlock + +fromOrgBlocksTight :: [OrgBlock] -> Doc +fromOrgBlocksTight = vcat . map fromOrgBlock + +fromOrgListItem :: String -> [OrgBlock] -> Doc +fromOrgListItem _ [] = empty +fromOrgListItem bullet (hd : rest) = hang (text bullet <+> fromOrgBlock hd) + (length bullet + 1) + (fromOrgBlocksTight rest) + +fromOrgInline :: OrgInline -> Doc +fromOrgInline (Plain doc ) = doc +fromOrgInline (Code doc ) = text "~" <> doc <> text "~" +fromOrgInline (Link target label) = brackets $ brackets target <> if null label + then empty + else brackets (fromOrgInlines label) +fromOrgInline (Bold inlines) = text "*" <> fromOrgInlines inlines <> text "*" +fromOrgInline (Italic inlines) = text "/" <> fromOrgInlines inlines <> text "/" +fromOrgInline (Anchor doc ) = text "<<" <> doc <> text ">>" +fromOrgInline Whitespace = text " " +fromOrgInline (MathInline doc) = text "\\(" <+> doc <+> text "\\)" + +fromOrgInlines :: [OrgInline] -> Doc +fromOrgInlines = hcat . map fromOrgInline + +-- * To string + +orgToString :: Doc -> String +orgToString = fullRender (PageMode True) 0 1 txtPrinter "" + +-- * Utilities for creating org elements + +cIdProp :: String -> Properties +cIdProp cid = [("CUSTOM_ID", cid)] + +cIdsProp :: [String] -> Properties +cIdsProp cids = map (\cid -> ("CUSTOM_ID", cid)) cids + +plaintext :: String -> OrgInline +plaintext = Plain . text . unfill + +unfill :: String -> String +unfill "" = "" +unfill s = + let + xs = lines s + preStripped = head xs : map (dropWhile isSpace) (tail xs) + stripped = + map (dropWhileEnd isSpace) (init preStripped) ++ [last preStripped] + in + unwords stripped + +fixLeadingStar :: String -> String +fixLeadingStar = + intercalate "\n" + . map + (\line -> + if not (null line) && head line == '*' then ' ' : line else line + ) + . lines + +headingPlainText :: String -> Int -> OrgBlock +headingPlainText title level = Heading level [plaintext title] [] + +headingPlainTextCId :: String -> String -> Int -> OrgBlock +headingPlainTextCId title cid level = + Heading level [plaintext title] (cIdProp cid) + +singleHeadingPlainText :: String -> Int -> [OrgBlock] +singleHeadingPlainText title level = [headingPlainText title level] + +singleHeadingPlain :: Doc -> Int -> [OrgBlock] +singleHeadingPlain title level = [Heading level [Plain title] []] + +singleHeadingPlainCId :: Doc -> String -> Int -> [OrgBlock] +singleHeadingPlainCId title cid level = + [Heading level [Plain title] (cIdProp cid)] + +orgParens :: [OrgInline] -> [OrgInline] +orgParens xs = plaintext "(" : xs ++ [plaintext ")"] + +orgBrackets :: [OrgInline] -> [OrgInline] +orgBrackets xs = plaintext "[" : xs ++ [plaintext "]"] |