1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE UndecidableInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE OverloadedStrings #-}
7module Commonmark.Extensions.DefinitionList
8  ( definitionListSpec
9  , HasDefinitionList(..)
10  )
11where
12import Commonmark.Types
13import Commonmark.Syntax
14import Commonmark.Blocks
15import Commonmark.SourceMap
16import Commonmark.TokParsers
17import Commonmark.Html
18import Control.Monad (mzero)
19#if !MIN_VERSION_base(4,11,0)
20import Data.Semigroup (Semigroup)
21import Data.Monoid
22#endif
23import Data.Dynamic
24import Data.Tree
25import Text.Parsec
26
27definitionListSpec :: (Monad m, IsBlock il bl, IsInline il,
28                       Typeable il, Typeable bl, HasDefinitionList il bl)
29                   => SyntaxSpec m il bl
30definitionListSpec = mempty
31  { syntaxBlockSpecs = [definitionListDefinitionBlockSpec]
32  }
33
34definitionListBlockSpec :: (Monad m, IsBlock il bl, HasDefinitionList il bl)
35                        => BlockSpec m il bl
36definitionListBlockSpec = BlockSpec
37     { blockType           = "DefinitionList"
38     , blockStart          = mzero
39     , blockCanContain     = \sp -> blockType sp == "DefinitionListItem"
40     , blockContainsLines  = False
41     , blockParagraph      = False
42     , blockContinue       = \n -> (,n) <$> getPosition
43     , blockConstructor    = \(Node bdata items) -> do
44         let listType = fromDyn (blockData bdata) LooseList
45         let getItem item@(Node _ ds) = do
46               term <- runInlineParser (getBlockText item)
47               defs <- mapM (\c -> blockConstructor (bspec c) c) ds
48               return $! (term, defs)
49         definitionList listType <$> mapM getItem items
50     , blockFinalize       = \(Node cdata children) parent -> do
51          let spacing =
52                if elem LooseList
53                     (map (\child ->
54                            fromDyn (blockData (rootLabel child))
55                              LooseList) children)
56                   then LooseList
57                   else TightList
58          defaultFinalizer (Node cdata{ blockData = toDyn spacing } children)
59                           parent
60     }
61
62definitionListItemBlockSpec ::
63   (Monad m, IsBlock il bl, IsInline il, HasDefinitionList il bl)
64   => BlockSpec m il bl
65definitionListItemBlockSpec = BlockSpec
66     { blockType           = "DefinitionListItem"
67     , blockStart          = mzero
68     , blockCanContain     = \sp -> blockType sp == "DefinitionListDefinition"
69     , blockContainsLines  = False
70     , blockParagraph      = False
71     , blockContinue       = \n -> (,n) <$> getPosition
72     , blockConstructor    = \_ -> mzero
73     , blockFinalize       = \(Node cdata children) parent -> do
74         let listSpacing   = fromDyn (blockData cdata) LooseList
75         let totight (Node nd cs)
76               | blockType (blockSpec nd) == "Paragraph"
77                           = Node nd{ blockSpec = plainSpec } cs
78               | otherwise = Node nd cs
79         let childrenToTight (Node nd cs) = Node nd (map totight cs)
80         let children' =
81                case listSpacing of
82                  TightList -> map childrenToTight children
83                  LooseList -> children
84         defaultFinalizer (Node cdata children') parent
85     }
86
87
88
89definitionListDefinitionBlockSpec ::
90   (Monad m, IsBlock il bl, IsInline il, HasDefinitionList il bl)
91   => BlockSpec m il bl
92definitionListDefinitionBlockSpec = BlockSpec
93     { blockType           = "DefinitionListDefinition"
94     , blockStart          = try $ do
95         n <- gobbleUpToSpaces 3
96         pos <- getPosition
97         symbol ':' <|> symbol '~'
98         gobbleSpaces (min 1 (3 - n))
99         (Node bdata children : rest) <- nodeStack <$> getState
100         let defnode = Node (defBlockData
101                              definitionListDefinitionBlockSpec){
102                                  blockStartPos = [pos] } []
103         if blockType (blockSpec bdata) == "DefinitionListItem"
104            then addNodeToStack defnode
105            else do
106             linode <-
107               if blockParagraph (blockSpec bdata)
108                 then do
109                   -- a) we're in a paragraph -> TightList
110                   --    make cur a DefinitionListItem instead
111                   --    keep the tokens; they will be the term
112                   -- remove paragraph from stack
113                   updateState $ \st -> st{ nodeStack = rest }
114                   return $! Node (defBlockData definitionListItemBlockSpec)
115                            { blockData = toDyn TightList
116                            , blockLines = blockLines bdata
117                            , blockStartPos = blockStartPos bdata
118                            } []
119                 else
120                   case children of
121                     (lastChild : rest')
122                       | blockParagraph (bspec lastChild) -> do
123                         -- b) previous sibling is a paragraph -> LooseList
124                         --    last child of cur is a Paragraph
125                         --    remove this child and mk new child with its
126                         --    content and position.  tokens will be term.
127                         -- remove paragraph from stack
128                         updateState $ \st -> st{ nodeStack =
129                              Node bdata rest' : rest }
130                         return $! Node (defBlockData
131                                    definitionListItemBlockSpec)
132                                  { blockData = toDyn LooseList
133                                  , blockStartPos = blockStartPos
134                                                     (rootLabel lastChild)
135                                  , blockLines = blockLines
136                                        (rootLabel lastChild)
137                                  } []
138                     _ -> mzero
139
140             let listnode = Node (defBlockData definitionListBlockSpec){
141                                blockStartPos = blockStartPos
142                                             (rootLabel linode) } []
143             (Node bdata' children' : rest') <- nodeStack <$> getState
144             -- if last child was DefinitionList, set that to current
145             case children' of
146               m:ms | blockType (blockSpec (rootLabel m)) == "DefinitionList"
147                   -> updateState $ \st -> st{ nodeStack =
148                        m : Node bdata' ms : rest' }
149               _ -> return ()
150             (Node bdata'' _ : _) <- nodeStack <$> getState
151             case blockType (blockSpec bdata'') of
152                  "DefinitionList"
153                    -> addNodeToStack linode >> addNodeToStack defnode
154                  _ -> addNodeToStack listnode >> addNodeToStack linode >>
155                       addNodeToStack defnode
156         return BlockStartMatch
157     , blockCanContain     = const True
158     , blockContainsLines  = False
159     , blockParagraph      = False
160     , blockContinue       = \node -> do
161         pos <- getPosition
162         gobbleSpaces 4 <|> 0 <$ lookAhead blankLine
163         return $! (pos, node)
164     , blockConstructor    = fmap mconcat . renderChildren
165     , blockFinalize       = defaultFinalizer
166     }
167
168class IsBlock il bl => HasDefinitionList il bl | il -> bl where
169  definitionList :: ListSpacing -> [(il,[bl])] -> bl
170
171instance Rangeable (Html a) =>
172         HasDefinitionList (Html a) (Html a) where
173  definitionList spacing items =
174    htmlBlock "dl" $ Just $ htmlRaw "\n" <>
175       mconcat (map (definitionListItem spacing) items)
176
177definitionListItem :: ListSpacing -> (Html a, [Html a]) -> Html a
178definitionListItem spacing (term, defns) =
179  htmlBlock "dt" (Just term) <>
180   mconcat (map (\defn ->
181            case spacing of
182              LooseList -> htmlBlock "dd" (Just (htmlRaw "\n" <> defn))
183              TightList -> htmlBlock "dd" (Just defn)) defns)
184
185instance (HasDefinitionList il bl, Semigroup bl, Semigroup il)
186        => HasDefinitionList (WithSourceMap il) (WithSourceMap bl) where
187  definitionList spacing items = do
188    let (terms, defs) = unzip items
189    terms' <- sequence terms
190    defs' <- mapM sequence defs
191    let res = definitionList spacing (zip terms' defs')
192    addName "definitionList"
193    return res
194