{-
Copyright (C) 2022 Yuchen Pei.
This file is part of haddorg-api.
This file is free software: you can redistribute it and/or modify it
under the terms of the GNU Affero General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This file is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public
License along with this file. If not, see
<https://www.gnu.org/licenses/>.
-}
{-# 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)]
hackageProp :: String -> Properties
hackageProp url = [("Hackage", url)]
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 "]"]
