Adding org backend.

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 "]"]