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