path: root/haddock-api/src/Haddock/Backends/Org/Types.hs

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