aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Org
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-07-18 18:08:00 +1000
committerYuchen Pei <hi@ypei.me>2022-07-18 18:08:00 +1000
commit1713efee8a913784e93746c4a339b2641a24df51 (patch)
treecb51e22721cc82760af1ebb8aa14c5b96ca068a6 /haddock-api/src/Haddock/Backends/Org
parent118dd4ed0c901f56070052405f533d9deff5bb22 (diff)
Adding org backend.
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Org')
-rw-r--r--haddock-api/src/Haddock/Backends/Org/Types.hs237
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 "]"]