commonmark-extensions-0.2.7: src/Commonmark/Extensions/TaskList.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.TaskList
( taskListSpec
, HasTaskList (..)
)
where
import Commonmark.Tokens
import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Blocks
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.Html
import Control.Monad (mzero)
import Control.Monad (when, guard)
import Data.List (sort)
import Data.Dynamic
import Data.Tree
import Text.Parsec
taskListSpec :: (Monad m, IsBlock il bl, IsInline il, HasTaskList il bl)
=> SyntaxSpec m il bl
taskListSpec = mempty
{ syntaxBlockSpecs = [taskListItemBlockSpec]
}
data ListData = ListData
{ listType :: !ListType
, listSpacing :: !ListSpacing
} deriving (Show, Eq)
data ListItemData = ListItemData
{ listItemType :: !ListType
, listItemChecked :: !Bool
, listItemIndent :: !Int
, listItemBlanksInside :: !Bool
, listItemBlanksAtEnd :: !Bool
} deriving (Show, Eq)
taskListBlockSpec :: (Monad m, IsBlock il bl,
HasTaskList il bl) => BlockSpec m il bl
taskListBlockSpec = BlockSpec
{ blockType = "TaskList"
, blockStart = mzero
, blockCanContain = \sp -> blockType sp == "TaskListItem"
, blockContainsLines = False
, blockParagraph = False
, blockContinue = \n -> (,n) <$> getPosition
, blockConstructor = \node -> do
let ListData lt ls = fromDyn (blockData (rootLabel node))
(ListData (BulletList '*') TightList)
let getCheckedStatus n =
listItemChecked $
fromDyn (blockData (rootLabel n))
(ListItemData (BulletList '*') False 0 False False)
let checkedStatus = map getCheckedStatus $ subForest node
taskList lt ls . zip checkedStatus <$> renderChildren node
, blockFinalize = \(Node cdata children) parent -> do
let ListData lt _ = fromDyn (blockData cdata)
(ListData (BulletList '*') TightList)
let getListItemData (Node d _) =
fromDyn (blockData d)
(ListItemData (BulletList '*') False 0 False False)
let childrenData = map getListItemData children
let ls = case childrenData of
c:cs | any listItemBlanksInside (c:cs) ||
(not (null cs) &&
any listItemBlanksAtEnd cs)
-> LooseList
_ -> TightList
blockBlanks' <- case childrenData of
c:_ | listItemBlanksAtEnd c -> do
curline <- sourceLine <$> getPosition
return $! curline - 1 : blockBlanks cdata
_ -> return $! blockBlanks cdata
let ldata' = toDyn (ListData lt ls)
-- need to transform paragraphs on tight lists
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' =
if ls == TightList
then map childrenToTight children
else children
defaultFinalizer (Node cdata{ blockData = ldata'
, blockBlanks = blockBlanks' } children')
parent
}
taskListItemBlockSpec :: (Monad m, IsBlock il bl, HasTaskList il bl)
=> BlockSpec m il bl
taskListItemBlockSpec = BlockSpec
{ blockType = "TaskListItem"
, blockStart = do
(pos, lidata) <- itemStart
let linode = Node (defBlockData taskListItemBlockSpec){
blockData = toDyn lidata,
blockStartPos = [pos] } []
let listdata = ListData{
listType = listItemType lidata
, listSpacing = TightList }
-- spacing gets set in finalize
let listnode = Node (defBlockData taskListBlockSpec){
blockData = toDyn listdata,
blockStartPos = [pos] } []
-- list can only interrupt paragraph if bullet
-- list or ordered list w/ startnum == 1,
-- and not followed by blank
(cur:_) <- nodeStack <$> getState
when (blockParagraph (bspec cur)) $ do
guard $ case listType listdata of
BulletList _ -> True
OrderedList 1 Decimal _ -> True
_ -> False
notFollowedBy blankLine
let curdata = fromDyn (blockData (rootLabel cur))
(ListData (BulletList '*') TightList)
let matchesList (BulletList c) (BulletList d) = c == d
matchesList (OrderedList _ e1 d1)
(OrderedList _ e2 d2) = e1 == e2 && d1 == d2
matchesList _ _ = False
case blockType (bspec cur) of
"TaskList" | listType curdata `matchesList`
listItemType lidata
-> addNodeToStack linode
_ -> addNodeToStack listnode >> addNodeToStack linode
blankAfterMarker <- optionMaybe blankLine
pos' <- getPosition
case blankAfterMarker of
Just _ -> return ()
Nothing -> do
toks <- many (satisfyTok (not . hasType LineEnd))
addNodeToStack $
Node (defBlockData paraSpec){
blockStartPos = [pos']
, blockLines = [toks] }
[]
return BlockStartMatch
, blockCanContain = const True
, blockContainsLines = False
, blockParagraph = False
, blockContinue = \node@(Node ndata children) -> do
let lidata = fromDyn (blockData ndata)
(ListItemData (BulletList '*') False 0
False False)
-- a marker followed by two blanks is just an empty item:
guard $ null (blockBlanks ndata) ||
not (null children)
pos <- getPosition
gobbleSpaces (listItemIndent lidata) <|> 0 <$ lookAhead blankLine
return $! (pos, node)
, blockConstructor = fmap mconcat . renderChildren
, blockFinalize = \(Node cdata children) parent -> do
let lidata = fromDyn (blockData cdata)
(ListItemData (BulletList '*') False
0 False False)
let blanks = removeConsecutive $ sort $
concat $ blockBlanks cdata :
map (blockBlanks . rootLabel)
(filter ((== "List") . blockType .
blockSpec . rootLabel) children)
curline <- sourceLine <$> getPosition
let blanksAtEnd = case blanks of
(l:_) -> l >= curline - 1
_ -> False
let blanksInside = case length blanks of
n | n > 1 -> True
| n == 1 -> not blanksAtEnd
| otherwise -> False
let lidata' = toDyn $ lidata{ listItemBlanksInside = blanksInside
, listItemBlanksAtEnd = blanksAtEnd }
defaultFinalizer (Node cdata{ blockData = lidata' } children)
parent
}
removeConsecutive :: [Int] -> [Int]
removeConsecutive (x:y:zs)
| x == y + 1 = removeConsecutive (y:zs)
removeConsecutive xs = xs
itemStart :: Monad m
=> BlockParser m il bl (SourcePos, ListItemData)
itemStart = do
beforecol <- sourceColumn <$> getPosition
gobbleUpToSpaces 3
pos <- getPosition
ty <- bulletListMarker
aftercol <- sourceColumn <$> getPosition
lookAhead whitespace
numspaces <- try (gobbleUpToSpaces 4 <* notFollowedBy whitespace)
<|> gobbleSpaces 1
checked <- parseCheckbox
lookAhead whitespace
return $! (pos, ListItemData{
listItemType = ty
, listItemChecked = checked
, listItemIndent = (aftercol - beforecol) + numspaces
, listItemBlanksInside = False
, listItemBlanksAtEnd = False
})
parseCheckbox :: Monad m => BlockParser m il bl Bool
parseCheckbox = do
gobbleUpToSpaces 3
symbol '['
checked <- (False <$ satisfyTok (hasType Spaces))
<|> (True <$ satisfyTok (textIs (\t -> t == "x" || t == "X")))
symbol ']'
return checked
class IsBlock il bl => HasTaskList il bl where
taskList :: ListType -> ListSpacing -> [(Bool, bl)] -> bl
instance Rangeable (Html a) => HasTaskList (Html a) (Html a) where
taskList lt spacing items =
addAttribute ("class","task-list")
$ list lt spacing
$ map addCheckbox items
addCheckbox :: (Bool, Html a) -> Html a
addCheckbox (checked, x) =
(addAttribute ("type", "checkbox") $
addAttribute ("disabled", "") $
(if checked then addAttribute ("checked","") else id) $
htmlInline "input" Nothing) <> x
instance (HasTaskList il bl, Semigroup bl, Semigroup il)
=> HasTaskList (WithSourceMap il) (WithSourceMap bl) where
taskList lt spacing items =
(do let (checks, xs) = unzip items
taskList lt spacing . zip checks <$> sequence xs
) <* addName "taskList"