AST.hs

{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
module Djot.AST
( Inline(..),
  Many(..),
  Inlines,
  MathStyle(..),
  Format(..),
  Node(Node),
  Pos(..),
  addAttr,
  addPos,
  Block(..),
  Blocks,
  Doc(..),
  NoteMap(..),
  insertNote,
  lookupNote,
  ReferenceMap(..),
  insertReference,
  lookupReference,
  normalizeLabel,
  Attr(..),
  Target(..),
  TaskStatus(..),
  Align(..),
  Cell(..),
  CellType(..),
  Caption(..),
  ListSpacing(..),
  OrderedListAttributes(..),
  OrderedListDelim(..),
  OrderedListStyle(..),
  QuoteType(..),
  delete,
  displayMath,
  insert,
  emailLink,
  emph,
  footnoteReference,
  hardBreak,
  highlight,
  image,
  inlineMath,
  link,
  nonBreakingSpace,
  rawInline,
  softBreak,
  span_,
  str,
  strong,
  subscript,
  superscript,
  singleQuoted,
  doubleQuoted,
  symbol,
  verbatim,
  urlLink,
  para,
  section,
  heading,
  blockQuote,
  codeBlock,
  div,
  bulletList,
  orderedList,
  definitionList,
  taskList,
  thematicBreak,
  table,
  rawBlock,
  inlinesToByteString
  )
where

import Prelude hiding (div)
import Data.ByteString (ByteString)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
import Data.Set (Set)
import Data.Data (Data, Typeable)
import qualified Data.ByteString.Char8 as B8
import GHC.Generics (Generic)
import Language.Haskell.TH.Syntax (Lift (..))

-- import Debug.Trace

newtype Attr = Attr [(ByteString, ByteString)]
  deriving (Show, Eq, Ord, Typeable, Data, Generic, Lift)

instance Semigroup Attr where
  Attr as <> Attr bs =
    Attr $ foldr integrate bs as

instance Monoid Attr where
  mappend = (<>)
  mempty = Attr mempty

integrate :: (ByteString, ByteString)
          -> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
integrate (k,v) kvs =
  case lookup k kvs of
    Nothing -> (k,v) : kvs
    Just v'
      | k == "class" ->
        (k, v <> " " <> v') : filter (\(k',_) -> k' /= "class") kvs
      | otherwise -> kvs

data Pos = NoPos | Pos Int Int Int Int -- start line, start col, end line, end col
  deriving (Show, Eq, Ord, Typeable, Data, Generic, Lift)

instance Semigroup Pos where
  Pos sl1 sc1 _ _ <> Pos _ _ el2 ec2 =
    Pos sl1 sc1 el2 ec2
  NoPos <> _ = NoPos
  _ <> NoPos = NoPos

instance Monoid Pos where
  mappend = (<>)
  mempty = NoPos

data Node a = Node Pos Attr a
  deriving (Show, Eq, Ord, Functor, Traversable, Foldable, Typeable, Data, Generic, Lift)

{-# INLINE addAttr #-}
addAttr :: Attr -> Node a -> Node a
addAttr attr (Node pos attr' bs) = Node pos (attr' <> attr) bs

{-# INLINE addPos #-}
addPos :: Pos -> Node a -> Node a
addPos pos (Node _ attr bs) = Node pos attr bs

newtype Format = Format { unFormat :: ByteString }
  deriving (Show, Eq, Ord, Typeable, Data, Generic, Lift)

data MathStyle = DisplayMath | InlineMath
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data Target =
    Direct ByteString
  | Reference ByteString
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data QuoteType = SingleQuotes | DoubleQuotes
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data Inline =
      Str ByteString
    | Emph Inlines
    | Strong Inlines
    | Highlight Inlines
    | Insert Inlines
    | Delete Inlines
    | Superscript Inlines
    | Subscript Inlines
    | Verbatim ByteString
    | Symbol ByteString
    | Math MathStyle ByteString
    | Link Inlines Target
    | Image Inlines Target
    | Span Inlines
    | FootnoteReference ByteString
    | UrlLink ByteString
    | EmailLink ByteString
    | RawInline Format ByteString
    | NonBreakingSpace
    | Quoted QuoteType Inlines
    | SoftBreak
    | HardBreak
    deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

newtype Many a = Many { unMany :: Seq a }
  deriving (Show, Ord, Eq, Functor, Traversable, Foldable, Typeable, Data, Generic, Lift)

type Inlines = Many (Node Inline)

instance Semigroup Inlines where
  Many as <> Many bs =
    case (Seq.viewr as, Seq.viewl bs) of
      (as' Seq.:> Node pos1 attr (Str s), Node pos2 attr' (Str t) Seq.:< bs')
        | attr == mempty && attr' /= mempty
        , (sa, sb) <- B8.spanEnd (not . isSpaceOrTab) s
        , not (B8.null sb)
          -> if B8.null sa
                then
                  Many (as' <> (Node (pos1 <> pos2) attr' (Str (s <> t)) Seq.<| bs'))
                else
                  let sblen = B8.length (B8.filter (\c -> c < '\128' || c >= '\192') sb)
                      (pos1', pos2') =
                        case pos1 <> pos2 of
                            NoPos -> (NoPos, NoPos)
                            Pos sl sc el ec ->
                              (Pos sl sc el (ec - sblen),
                               Pos sl (sc + sblen + 1) el ec)
                  in  Many ((as' Seq.|> Node pos1' mempty (Str sa)
                        Seq.|> Node pos2' attr (Str (sb <> t))) <> bs')
        | attr == attr'
          -> Many (as' <> (Node (pos1 <> pos2) attr (Str (s <> t)) Seq.<| bs'))
      (as' Seq.:> Node pos attr (Str s), Node _ _ HardBreak Seq.:< _)
        | B8.all isSpaceOrTab (B8.takeEnd 1 s)
          -> Many (as' <> (Node pos attr (Str (B8.dropWhileEnd isSpaceOrTab s))
                            Seq.<| bs))
      _ -> Many (as <> bs)
    where
      isSpaceOrTab ' ' = True
      isSpaceOrTab '\t' = True
      isSpaceOrTab _ = False

instance Monoid Inlines where
  mappend = (<>)
  mempty = Many mempty

data ListSpacing = Tight | Loose
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data OrderedListStyle =
  Decimal | LetterUpper | LetterLower | RomanUpper | RomanLower
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data OrderedListDelim =
  RightPeriod | RightParen | LeftRightParen
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data OrderedListAttributes =
  OrderedListAttributes
  { orderedListStyle :: OrderedListStyle
  , orderedListDelim :: OrderedListDelim
  , orderedListStart :: Int }
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data TaskStatus = Complete | Incomplete
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

newtype Caption = Caption Blocks
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data Align = AlignLeft | AlignRight | AlignCenter | AlignDefault
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data CellType = HeadCell | BodyCell
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data Cell = Cell CellType Align Inlines
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

data Block =
    Para Inlines
  | Section Blocks
  | Heading Int Inlines
  | BlockQuote Blocks
  | CodeBlock ByteString ByteString
  | Div Blocks
  | OrderedList OrderedListAttributes ListSpacing [Blocks]
  | BulletList ListSpacing [Blocks]
  | TaskList ListSpacing [(TaskStatus, Blocks)]
  | DefinitionList ListSpacing [(Inlines, Blocks)]
  | ThematicBreak
  | Table (Maybe Caption) [[Cell]]
  | RawBlock Format ByteString
  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

type Blocks = Many (Node Block)

instance Semigroup Blocks where
  Many as <> Many bs = Many (as <> bs)

instance Monoid Blocks where
  mappend = (<>)
  mempty = Many mempty

data Doc =
  Doc{ docBlocks :: Blocks
     , docFootnotes :: NoteMap
     , docReferences :: ReferenceMap
     , docAutoReferences :: ReferenceMap
     , docAutoIdentifiers :: Set ByteString
     } deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)

instance Semigroup Doc where
  Doc bs ns rs ar ai <> Doc bs' ns' rs' ar' ai' =
    Doc (bs <> bs') (ns <> ns') (rs <> rs') (ar <> ar') (ai <> ai')

instance Monoid Doc where
  mappend = (<>)
  mempty = Doc mempty mempty mempty mempty mempty

-- | A map from labels to contents.
newtype NoteMap = NoteMap { unNoteMap :: M.Map ByteString Blocks }
  deriving (Show, Ord, Eq, Semigroup, Monoid, Typeable, Data, Generic, Lift)

insertNote :: ByteString -> Blocks -> NoteMap -> NoteMap
insertNote label ref (NoteMap m) =
  NoteMap (M.insert (normalizeLabel label) ref m)

lookupNote :: ByteString -> NoteMap -> Maybe Blocks
lookupNote label (NoteMap m) =
  M.lookup (normalizeLabel label) m

newtype ReferenceMap =
  ReferenceMap { unReferenceMap :: M.Map ByteString (ByteString, Attr) }
  deriving (Show, Ord, Eq, Semigroup, Monoid, Typeable, Data, Generic, Lift)

normalizeLabel :: ByteString -> ByteString
normalizeLabel = B8.unwords . B8.splitWith isWs
 where
  isWs c = c == ' ' || c == '\t' || c == '\r' || c == '\n'

insertReference :: ByteString -> (ByteString, Attr) -> ReferenceMap
                -> ReferenceMap
insertReference label ref (ReferenceMap rm) =
  ReferenceMap (M.insert (normalizeLabel label) ref rm)

lookupReference :: ByteString -> ReferenceMap -> Maybe (ByteString, Attr)
lookupReference label (ReferenceMap rm) =
  M.lookup (normalizeLabel label) rm

{-# INLINE inline #-}
inline :: Inline -> Inlines
inline = Many . Seq.singleton . Node NoPos mempty

str, verbatim, symbol :: ByteString -> Inlines
str = inline . Str
verbatim = inline . Verbatim
symbol = inline . Symbol

emph, strong, superscript, subscript :: Inlines -> Inlines
emph = inline . Emph
strong = inline . Strong
superscript = inline . Superscript
subscript = inline . Subscript

highlight, insert, delete :: Inlines -> Inlines
highlight = inline . Highlight
insert = inline . Insert
delete = inline . Delete

link, image :: Inlines -> Target -> Inlines
link ils url = inline $ Link ils url
image ils url = inline $ Image ils url

span_ :: Inlines -> Inlines
span_ = inline . Span

softBreak, hardBreak, nonBreakingSpace :: Inlines
softBreak = inline SoftBreak
hardBreak = inline HardBreak
nonBreakingSpace = inline NonBreakingSpace

inlineMath, displayMath :: ByteString -> Inlines
inlineMath = inline . Math InlineMath
displayMath = inline . Math DisplayMath

singleQuoted, doubleQuoted :: Inlines -> Inlines
singleQuoted = inline . Quoted SingleQuotes
doubleQuoted = inline . Quoted DoubleQuotes

footnoteReference :: ByteString -> Inlines
footnoteReference = inline . FootnoteReference

urlLink, emailLink :: ByteString -> Inlines
urlLink = inline . UrlLink
emailLink = inline . EmailLink

rawInline :: Format -> ByteString -> Inlines
rawInline f = inline . RawInline f


--

block :: Block -> Blocks
block = Many . Seq.singleton . Node NoPos mempty

para :: Inlines -> Blocks
para = block . Para

section :: Blocks -> Blocks
section = block . Section

heading :: Int -> Inlines -> Blocks
heading lev = block . Heading lev

blockQuote :: Blocks -> Blocks
blockQuote = block . BlockQuote

codeBlock :: ByteString -> ByteString -> Blocks
codeBlock lang bs = block $ CodeBlock lang bs

bulletList :: ListSpacing -> [Blocks] -> Blocks
bulletList tightness = block . BulletList tightness

orderedList :: OrderedListAttributes -> ListSpacing -> [Blocks] -> Blocks
orderedList attr tightness = block . OrderedList attr tightness

definitionList :: ListSpacing -> [(Inlines, Blocks)] -> Blocks
definitionList tightness = block . DefinitionList tightness

taskList :: ListSpacing -> [(TaskStatus, Blocks)] -> Blocks
taskList tightness = block . TaskList tightness

div :: Blocks -> Blocks
div = block . Div

thematicBreak :: Blocks
thematicBreak = block ThematicBreak

table :: Maybe Caption -> [[Cell]] -> Blocks
table mbCaption = block . Table mbCaption

rawBlock :: Format -> ByteString -> Blocks
rawBlock f = block . RawBlock f

inlinesToByteString :: Inlines -> ByteString
inlinesToByteString = foldMap go . unMany
 where
  go (Node _pos _attr x) =
      case x of
        Str bs -> bs
        Emph ils -> inlinesToByteString ils
        Strong ils -> inlinesToByteString ils
        Highlight ils -> inlinesToByteString ils
        Insert ils -> inlinesToByteString ils
        Delete ils -> inlinesToByteString ils
        Superscript ils -> inlinesToByteString ils
        Subscript ils -> inlinesToByteString ils
        Quoted SingleQuotes ils ->
          "\x2018" <> inlinesToByteString ils <> "\x2019"
        Quoted DoubleQuotes ils ->
          "\x201C" <> inlinesToByteString ils <> "\x201D"
        Verbatim bs -> bs
        Math DisplayMath bs -> "$$" <> bs <> "$$"
        Math InlineMath bs -> "$" <> bs <> "$"
        Symbol bs -> ":" <> bs <> ":"
        Link ils _url -> inlinesToByteString ils
        Image ils _url -> inlinesToByteString ils
        Span ils -> inlinesToByteString ils
        UrlLink url -> url
        EmailLink email -> email
        RawInline _ _ -> mempty
        FootnoteReference bs -> "[" <> bs <> "]"
        SoftBreak -> "\n"
        HardBreak -> "\n"
        NonBreakingSpace -> "\160"