DefinitionList.hs

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Commonmark.Extensions.DefinitionList
  ( definitionListSpec
  , HasDefinitionList(..)
  )
where
import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Blocks
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.Html
import Commonmark.Nodes hiding (Node (..))
import Control.Monad (mzero)
import Data.Dynamic
import Data.Tree
import qualified Data.Text as T
import Text.Parsec

definitionListSpec :: (Monad m, IsBlock il bl, IsInline il,
                       Typeable il, Typeable bl, HasDefinitionList il bl)
                   => SyntaxSpec m il bl
definitionListSpec = mempty
  { syntaxBlockSpecs = [definitionListDefinitionBlockSpec]
  }

definitionListBlockSpec :: (Monad m, IsBlock il bl, HasDefinitionList il bl)
                        => BlockSpec m il bl
definitionListBlockSpec = BlockSpec
     { blockType           = "DefinitionList"
     , blockStart          = mzero
     , blockCanContain     = \sp -> blockType sp == "DefinitionListItem"
     , blockContainsLines  = False
     , blockParagraph      = False
     , blockContinue       = \n -> (,n) <$> getPosition
     , blockConstructor    = \(Node bdata items) -> do
         let listType = fromDyn (blockData bdata) LooseList
         let getItem item@(Node _ ds) = do
               term <- runInlineParser (getBlockText item)
               defs <- mapM (\c -> blockConstructor (bspec c) c) ds
               return $! (term, defs)
         definitionList listType <$> mapM getItem items
     , blockFinalize       = \(Node cdata children) parent -> do
          let spacing =
                if elem LooseList
                     (map (\child ->
                            fromDyn (blockData (rootLabel child))
                              LooseList) children)
                   then LooseList
                   else TightList
          defaultFinalizer (Node cdata{ blockData = toDyn spacing } children)
                           parent
     }

definitionListItemBlockSpec ::
   (Monad m, IsBlock il bl, IsInline il, HasDefinitionList il bl)
   => BlockSpec m il bl
definitionListItemBlockSpec = BlockSpec
     { blockType           = "DefinitionListItem"
     , blockStart          = mzero
     , blockCanContain     = \sp -> blockType sp == "DefinitionListDefinition"
     , blockContainsLines  = False
     , blockParagraph      = False
     , blockContinue       = \n -> (,n) <$> getPosition
     , blockConstructor    = \_ -> mzero
     , blockFinalize       = \(Node cdata children) parent -> do
         let listSpacing   = fromDyn (blockData cdata) LooseList
         let totight (Node nd cs)
               | blockType (blockSpec nd) == "Paragraph"
                           = Node nd{ blockSpec = plainSpec } cs
               | otherwise = Node nd cs
         let childrenToTight (Node nd cs) = Node nd (map totight cs)
         let children' =
                case listSpacing of
                  TightList -> map childrenToTight children
                  LooseList -> children
         defaultFinalizer (Node cdata children') parent
     }


definitionListDefinitionBlockSpec ::
   (Monad m, IsBlock il bl, IsInline il, HasDefinitionList il bl)
   => BlockSpec m il bl
definitionListDefinitionBlockSpec = BlockSpec
     { blockType           = "DefinitionListDefinition"
     , blockStart          = try $ do
         initcol <- sourceColumn <$> getPosition
         gobbleUpToSpaces 3
         pos <- getPosition
         symbol ':' <|> symbol '~'
         try (gobbleUpToSpaces 4 <* notFollowedBy whitespace)
           <|> gobbleSpaces 1
           <|> 1 <$ lookAhead lineEnd
         finalcol <- sourceColumn <$> getPosition
         (Node bdata children : rest) <- nodeStack <$> getState
         let definitionIndent :: Int
             definitionIndent = finalcol - initcol
         let defnode = Node (defBlockData
                              definitionListDefinitionBlockSpec){
                                  blockStartPos = [pos],
                                  blockData = toDyn definitionIndent } []
         if blockType (blockSpec bdata) == "DefinitionListItem"
            then addNodeToStack defnode
            else do
             linode <-
               if blockParagraph (blockSpec bdata)
                 then do
                   -- a) we're in a paragraph -> TightList
                   --    make cur a DefinitionListItem instead
                   --    keep the tokens; they will be the term
                   -- remove paragraph from stack
                   updateState $ \st -> st{ nodeStack = rest }
                   return $! Node (defBlockData definitionListItemBlockSpec)
                            { blockData = toDyn TightList
                            , blockLines = blockLines bdata
                            , blockStartPos = blockStartPos bdata
                            } []
                 else
                   case children of
                     (lastChild : rest')
                       | blockParagraph (bspec lastChild) -> do
                         -- b) previous sibling is a paragraph -> LooseList
                         --    last child of cur is a Paragraph
                         --    remove this child and mk new child with its
                         --    content and position.  tokens will be term.
                         -- remove paragraph from stack
                         updateState $ \st -> st{ nodeStack =
                              Node bdata rest' : rest }
                         return $! Node (defBlockData
                                    definitionListItemBlockSpec)
                                  { blockData = toDyn LooseList
                                  , blockStartPos = blockStartPos
                                                     (rootLabel lastChild)
                                  , blockLines = blockLines
                                        (rootLabel lastChild)
                                  } []
                     _ -> mzero

             let listnode = Node (defBlockData definitionListBlockSpec){
                                blockStartPos = blockStartPos
                                             (rootLabel linode) } []
             (Node bdata' children' : rest') <- nodeStack <$> getState
             -- if last child was DefinitionList, set that to current
             case children' of
               m:ms | blockType (blockSpec (rootLabel m)) == "DefinitionList"
                   -> updateState $ \st -> st{ nodeStack =
                        m : Node bdata' ms : rest' }
               _ -> return ()
             (Node bdata'' _ : _) <- nodeStack <$> getState
             case blockType (blockSpec bdata'') of
                  "DefinitionList"
                    -> addNodeToStack linode >> addNodeToStack defnode
                  _ -> addNodeToStack listnode >> addNodeToStack linode >>
                       addNodeToStack defnode
         return BlockStartMatch
     , blockCanContain     = const True
     , blockContainsLines  = False
     , blockParagraph      = False
     , blockContinue       = \node@(Node ndata _cs) -> do
         pos <- getPosition
         let definitionIndent = fromDyn (blockData ndata) 0
         gobbleSpaces definitionIndent <|> 0 <$ lookAhead blankLine
         return $! (pos, node)
     , blockConstructor    = fmap mconcat . renderChildren
     , blockFinalize       = defaultFinalizer
     }

class IsBlock il bl => HasDefinitionList il bl | il -> bl where
  definitionList :: ListSpacing -> [(il,[bl])] -> bl

instance Rangeable (Html a) =>
         HasDefinitionList (Html a) (Html a) where
  definitionList spacing items =
    htmlBlock "dl" $ Just $ htmlRaw "\n" <>
       mconcat (map (definitionListItem spacing) items)

definitionListItem :: ListSpacing -> (Html a, [Html a]) -> Html a
definitionListItem spacing (term, defns) =
  htmlBlock "dt" (Just term) <>
   mconcat (map (\defn ->
            case spacing of
              LooseList -> htmlBlock "dd" (Just (htmlRaw "\n" <> defn))
              TightList -> htmlBlock "dd" (Just defn)) defns)

instance (HasDefinitionList il bl, Semigroup bl, Semigroup il)
        => HasDefinitionList (WithSourceMap il) (WithSourceMap bl) where
  definitionList spacing items = do
    let (terms, defs) = unzip items
    terms' <- sequence terms
    defs' <- mapM sequence defs
    let res = definitionList spacing (zip terms' defs')
    addName "definitionList"
    return res

data NodeTypeDefinitionList a
  = NodeDefinitionList ListSpacing [(Nodes a, [Nodes a])]
  deriving (Show)

instance Typeable a => NodeType NodeTypeDefinitionList a where
  type FromNodeType NodeTypeDefinitionList a = HasDefinitionList a a
  fromNodeType = \case
    NodeDefinitionList spacing items ->
      definitionList
        spacing
        [ (fromNodes term, map fromNodes defs)
        | (term, defs) <- items
        ]

instance ToPlainText (NodeTypeDefinitionList a) where
  toPlainText = \case
    NodeDefinitionList _ items ->
      T.unlines . concat $
        [ (toPlainText term <> ":") : map toPlainText defs
        | (term, defs) <- items
        ]

instance (Typeable a, HasDefinitionList a a) => HasDefinitionList (Nodes a) (Nodes a) where
  definitionList spacing items = singleNode $ NodeDefinitionList spacing items