{-# 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 :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasTaskList il bl) =>
SyntaxSpec m il bl
taskListSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
{ syntaxBlockSpecs = [taskListItemBlockSpec]
}
data ListData = ListData
{ ListData -> ListType
listType :: !ListType
, ListData -> ListSpacing
listSpacing :: !ListSpacing
} deriving (Int -> ListData -> ShowS
[ListData] -> ShowS
ListData -> String
(Int -> ListData -> ShowS)
-> (ListData -> String) -> ([ListData] -> ShowS) -> Show ListData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListData -> ShowS
showsPrec :: Int -> ListData -> ShowS
$cshow :: ListData -> String
show :: ListData -> String
$cshowList :: [ListData] -> ShowS
showList :: [ListData] -> ShowS
Show, ListData -> ListData -> Bool
(ListData -> ListData -> Bool)
-> (ListData -> ListData -> Bool) -> Eq ListData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListData -> ListData -> Bool
== :: ListData -> ListData -> Bool
$c/= :: ListData -> ListData -> Bool
/= :: ListData -> ListData -> Bool
Eq)
data ListItemData = ListItemData
{ ListItemData -> ListType
listItemType :: !ListType
, ListItemData -> Bool
listItemChecked :: !Bool
, ListItemData -> Int
listItemIndent :: !Int
, ListItemData -> Bool
listItemBlanksInside :: !Bool
, ListItemData -> Bool
listItemBlanksAtEnd :: !Bool
} deriving (Int -> ListItemData -> ShowS
[ListItemData] -> ShowS
ListItemData -> String
(Int -> ListItemData -> ShowS)
-> (ListItemData -> String)
-> ([ListItemData] -> ShowS)
-> Show ListItemData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListItemData -> ShowS
showsPrec :: Int -> ListItemData -> ShowS
$cshow :: ListItemData -> String
show :: ListItemData -> String
$cshowList :: [ListItemData] -> ShowS
showList :: [ListItemData] -> ShowS
Show, ListItemData -> ListItemData -> Bool
(ListItemData -> ListItemData -> Bool)
-> (ListItemData -> ListItemData -> Bool) -> Eq ListItemData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListItemData -> ListItemData -> Bool
== :: ListItemData -> ListItemData -> Bool
$c/= :: ListItemData -> ListItemData -> Bool
/= :: ListItemData -> ListItemData -> Bool
Eq)
taskListBlockSpec :: (Monad m, IsBlock il bl,
HasTaskList il bl) => BlockSpec m il bl
taskListBlockSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasTaskList il bl) =>
BlockSpec m il bl
taskListBlockSpec = BlockSpec
{ blockType :: Text
blockType = Text
"TaskList"
, blockStart :: BlockParser m il bl BlockStartResult
blockStart = BlockParser m il bl BlockStartResult
forall a. ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
, blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain = \BlockSpec m il bl
sp -> BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType BlockSpec m il bl
sp Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"TaskListItem"
, blockContainsLines :: Bool
blockContainsLines = Bool
False
, blockParagraph :: Bool
blockParagraph = Bool
False
, blockContinue :: BlockNode m il bl
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
blockContinue = \BlockNode m il bl
n -> (,BlockNode m il bl
n) (SourcePos -> (SourcePos, BlockNode m il bl))
-> ParsecT [Tok] (BPState m il bl) m SourcePos
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
, blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor = \BlockNode m il bl
node -> do
let ListData ListType
lt ListSpacing
ls = Dynamic -> ListData -> ListData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
(ListType -> ListSpacing -> ListData
ListData (Char -> ListType
BulletList Char
'*') ListSpacing
TightList)
let getCheckedStatus :: Tree (BlockData m il bl) -> Bool
getCheckedStatus Tree (BlockData m il bl)
n =
ListItemData -> Bool
listItemChecked (ListItemData -> Bool) -> ListItemData -> Bool
forall a b. (a -> b) -> a -> b
$
Dynamic -> ListItemData -> ListItemData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (Tree (BlockData m il bl) -> BlockData m il bl
forall a. Tree a -> a
rootLabel Tree (BlockData m il bl)
n))
(ListType -> Bool -> Int -> Bool -> Bool -> ListItemData
ListItemData (Char -> ListType
BulletList Char
'*') Bool
False Int
0 Bool
False Bool
False)
let checkedStatus :: [Bool]
checkedStatus = (BlockNode m il bl -> Bool) -> [BlockNode m il bl] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode m il bl -> Bool
forall {m :: * -> *} {il} {bl}. Tree (BlockData m il bl) -> Bool
getCheckedStatus ([BlockNode m il bl] -> [Bool]) -> [BlockNode m il bl] -> [Bool]
forall a b. (a -> b) -> a -> b
$ BlockNode m il bl -> [BlockNode m il bl]
forall a. Tree a -> [Tree a]
subForest BlockNode m il bl
node
ListType -> ListSpacing -> [(Bool, bl)] -> bl
forall il bl.
HasTaskList il bl =>
ListType -> ListSpacing -> [(Bool, bl)] -> bl
taskList ListType
lt ListSpacing
ls ([(Bool, bl)] -> bl) -> ([bl] -> [(Bool, bl)]) -> [bl] -> bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [bl] -> [(Bool, bl)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
checkedStatus ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl]
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
BlockNode m il bl -> BlockParser m il bl [bl]
renderChildren BlockNode m il bl
node
, blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize = \(Node BlockData m il bl
cdata [BlockNode m il bl]
children) BlockNode m il bl
parent -> do
let ListData ListType
lt ListSpacing
_ = Dynamic -> ListData -> ListData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
cdata)
(ListType -> ListSpacing -> ListData
ListData (Char -> ListType
BulletList Char
'*') ListSpacing
TightList)
let getListItemData :: Tree (BlockData m il bl) -> ListItemData
getListItemData (Node BlockData m il bl
d [Tree (BlockData m il bl)]
_) =
Dynamic -> ListItemData -> ListItemData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
d)
(ListType -> Bool -> Int -> Bool -> Bool -> ListItemData
ListItemData (Char -> ListType
BulletList Char
'*') Bool
False Int
0 Bool
False Bool
False)
let childrenData :: [ListItemData]
childrenData = (BlockNode m il bl -> ListItemData)
-> [BlockNode m il bl] -> [ListItemData]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode m il bl -> ListItemData
forall {m :: * -> *} {il} {bl}.
Tree (BlockData m il bl) -> ListItemData
getListItemData [BlockNode m il bl]
children
let ls :: ListSpacing
ls = case [ListItemData]
childrenData of
ListItemData
c:[ListItemData]
cs | (ListItemData -> Bool) -> [ListItemData] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ListItemData -> Bool
listItemBlanksInside (ListItemData
cListItemData -> [ListItemData] -> [ListItemData]
forall a. a -> [a] -> [a]
:[ListItemData]
cs) Bool -> Bool -> Bool
||
(Bool -> Bool
not ([ListItemData] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ListItemData]
cs) Bool -> Bool -> Bool
&&
(ListItemData -> Bool) -> [ListItemData] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ListItemData -> Bool
listItemBlanksAtEnd [ListItemData]
cs)
-> ListSpacing
LooseList
[ListItemData]
_ -> ListSpacing
TightList
blockBlanks' <- case [ListItemData]
childrenData of
ListItemData
c:[ListItemData]
_ | ListItemData -> Bool
listItemBlanksAtEnd ListItemData
c -> do
curline <- SourcePos -> Int
sourceLine (SourcePos -> Int)
-> ParsecT [Tok] (BPState m il bl) m SourcePos
-> ParsecT [Tok] (BPState m il bl) m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
return $! curline - 1 : blockBlanks cdata
[ListItemData]
_ -> [Int] -> ParsecT [Tok] (BPState m il bl) m [Int]
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> ParsecT [Tok] (BPState m il bl) m [Int])
-> [Int] -> ParsecT [Tok] (BPState m il bl) m [Int]
forall a b. (a -> b) -> a -> b
$! BlockData m il bl -> [Int]
forall (m :: * -> *) il bl. BlockData m il bl -> [Int]
blockBlanks BlockData m il bl
cdata
let ldata' = ListData -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (ListType -> ListSpacing -> ListData
ListData ListType
lt ListSpacing
ls)
let totight (Node BlockData m il bl
nd [Tree (BlockData m il bl)]
cs)
| BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec BlockData m il bl
nd) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Paragraph"
= BlockData m il bl
-> [Tree (BlockData m il bl)] -> Tree (BlockData m il bl)
forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
nd{ blockSpec = plainSpec } [Tree (BlockData m il bl)]
cs
| Bool
otherwise = BlockData m il bl
-> [Tree (BlockData m il bl)] -> Tree (BlockData m il bl)
forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
nd [Tree (BlockData m il bl)]
cs
let childrenToTight (Node BlockData m il bl
nd [Tree (BlockData m il bl)]
cs) = BlockData m il bl
-> [Tree (BlockData m il bl)] -> Tree (BlockData m il bl)
forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
nd ((Tree (BlockData m il bl) -> Tree (BlockData m il bl))
-> [Tree (BlockData m il bl)] -> [Tree (BlockData m il bl)]
forall a b. (a -> b) -> [a] -> [b]
map Tree (BlockData m il bl) -> Tree (BlockData m il bl)
forall {m :: * -> *} {il} {bl}.
(Monad m, IsBlock il bl) =>
Tree (BlockData m il bl) -> Tree (BlockData m il bl)
totight [Tree (BlockData m il bl)]
cs)
let children' =
if ListSpacing
ls ListSpacing -> ListSpacing -> Bool
forall a. Eq a => a -> a -> Bool
== ListSpacing
TightList
then (BlockNode m il bl -> BlockNode m il bl)
-> [BlockNode m il bl] -> [BlockNode m il bl]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode m il bl -> BlockNode m il bl
forall {m :: * -> *} {il} {bl}.
(Monad m, IsBlock il bl) =>
Tree (BlockData m il bl) -> Tree (BlockData m il bl)
childrenToTight [BlockNode m il bl]
children
else [BlockNode m il bl]
children
defaultFinalizer (Node cdata{ blockData = ldata'
, blockBlanks = blockBlanks' } children')
parent
}
taskListItemBlockSpec :: (Monad m, IsBlock il bl, HasTaskList il bl)
=> BlockSpec m il bl
taskListItemBlockSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasTaskList il bl) =>
BlockSpec m il bl
taskListItemBlockSpec = BlockSpec
{ blockType :: Text
blockType = Text
"TaskListItem"
, blockStart :: BlockParser m il bl BlockStartResult
blockStart = do
(pos, lidata) <- BlockParser m il bl (SourcePos, ListItemData)
forall (m :: * -> *) il bl.
Monad m =>
BlockParser m il bl (SourcePos, ListItemData)
itemStart
let linode = BlockData m il bl -> [BlockNode m il bl] -> BlockNode m il bl
forall a. a -> [Tree a] -> Tree a
Node (BlockSpec m il bl -> BlockData m il bl
forall (m :: * -> *) il bl. BlockSpec m il bl -> BlockData m il bl
defBlockData BlockSpec m il bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasTaskList il bl) =>
BlockSpec m il bl
taskListItemBlockSpec){
blockData = toDyn lidata,
blockStartPos = [pos] } []
let listdata = ListData{
listType :: ListType
listType = ListItemData -> ListType
listItemType ListItemData
lidata
, listSpacing :: ListSpacing
listSpacing = ListSpacing
TightList }
let listnode = BlockData m il bl -> [BlockNode m il bl] -> BlockNode m il bl
forall a. a -> [Tree a] -> Tree a
Node (BlockSpec m il bl -> BlockData m il bl
forall (m :: * -> *) il bl. BlockSpec m il bl -> BlockData m il bl
defBlockData BlockSpec m il bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasTaskList il bl) =>
BlockSpec m il bl
taskListBlockSpec){
blockData = toDyn listdata,
blockStartPos = [pos] } []
(cur:_) <- nodeStack <$> getState
when (blockParagraph (bspec cur)) $ do
guard $ case listType listdata of
BulletList Char
_ -> Bool
True
OrderedList Int
1 EnumeratorType
Decimal DelimiterType
_ -> Bool
True
ListType
_ -> Bool
False
notFollowedBy blankLine
let curdata = Dynamic -> ListData -> ListData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
cur))
(ListType -> ListSpacing -> ListData
ListData (Char -> ListType
BulletList Char
'*') ListSpacing
TightList)
let matchesList (BulletList Char
c) (BulletList Char
d) = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d
matchesList (OrderedList Int
_ EnumeratorType
e1 DelimiterType
d1)
(OrderedList Int
_ EnumeratorType
e2 DelimiterType
d2) = EnumeratorType
e1 EnumeratorType -> EnumeratorType -> Bool
forall a. Eq a => a -> a -> Bool
== EnumeratorType
e2 Bool -> Bool -> Bool
&& DelimiterType
d1 DelimiterType -> DelimiterType -> Bool
forall a. Eq a => a -> a -> Bool
== DelimiterType
d2
matchesList ListType
_ ListType
_ = Bool
False
case blockType (bspec cur) of
Text
"TaskList" | ListData -> ListType
listType ListData
curdata ListType -> ListType -> Bool
`matchesList`
ListItemData -> ListType
listItemType ListItemData
lidata
-> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) bl il.
Monad m =>
BlockNode m bl il -> BlockParser m bl il ()
addNodeToStack BlockNode m il bl
linode
Text
_ -> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) bl il.
Monad m =>
BlockNode m bl il -> BlockParser m bl il ()
addNodeToStack BlockNode m il bl
listnode ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b.
ParsecT [Tok] (BPState m il bl) m a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) bl il.
Monad m =>
BlockNode m bl il -> BlockParser m bl il ()
addNodeToStack BlockNode m il bl
linode
return BlockStartMatch
, blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain = Bool -> BlockSpec m il bl -> Bool
forall a b. a -> b -> a
const Bool
True
, blockContainsLines :: Bool
blockContainsLines = Bool
False
, blockParagraph :: Bool
blockParagraph = Bool
False
, blockContinue :: BlockNode m il bl
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
blockContinue = \node :: BlockNode m il bl
node@(Node BlockData m il bl
ndata [BlockNode m il bl]
children) -> do
let lidata :: ListItemData
lidata = Dynamic -> ListItemData -> ListItemData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
ndata)
(ListType -> Bool -> Int -> Bool -> Bool -> ListItemData
ListItemData (Char -> ListType
BulletList Char
'*') Bool
False Int
0
Bool
False Bool
False)
Bool -> ParsecT [Tok] (BPState m il bl) m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Tok] (BPState m il bl) m ())
-> Bool -> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BlockData m il bl -> [Int]
forall (m :: * -> *) il bl. BlockData m il bl -> [Int]
blockBlanks BlockData m il bl
ndata) Bool -> Bool -> Bool
||
Bool -> Bool
not ([BlockNode m il bl] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockNode m il bl]
children)
pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
gobbleSpaces (listItemIndent lidata) <|> 0 <$ lookAhead blankLine
return $! (pos, node)
, blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor = ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall a b.
(a -> b)
-> ParsecT [Tok] (BPState m il bl) m a
-> ParsecT [Tok] (BPState m il bl) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [bl] -> bl
forall a. Monoid a => [a] -> a
mconcat (ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl)
-> (BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl])
-> BlockNode m il bl
-> BlockParser m il bl bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl]
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
BlockNode m il bl -> BlockParser m il bl [bl]
renderChildren
, blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize = \(Node BlockData m il bl
cdata [BlockNode m il bl]
children) BlockNode m il bl
parent -> do
let lidata :: ListItemData
lidata = Dynamic -> ListItemData -> ListItemData
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
cdata)
(ListType -> Bool -> Int -> Bool -> Bool -> ListItemData
ListItemData (Char -> ListType
BulletList Char
'*') Bool
False
Int
0 Bool
False Bool
False)
let blanks :: [Int]
blanks = [Int] -> [Int]
removeConsecutive ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
[[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ BlockData m il bl -> [Int]
forall (m :: * -> *) il bl. BlockData m il bl -> [Int]
blockBlanks BlockData m il bl
cdata [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:
(BlockNode m il bl -> [Int]) -> [BlockNode m il bl] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (BlockData m il bl -> [Int]
forall (m :: * -> *) il bl. BlockData m il bl -> [Int]
blockBlanks (BlockData m il bl -> [Int])
-> (BlockNode m il bl -> BlockData m il bl)
-> BlockNode m il bl
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel)
((BlockNode m il bl -> Bool)
-> [BlockNode m il bl] -> [BlockNode m il bl]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"List") (Text -> Bool)
-> (BlockNode m il bl -> Text) -> BlockNode m il bl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockSpec m il bl -> Text)
-> (BlockNode m il bl -> BlockSpec m il bl)
-> BlockNode m il bl
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec (BlockData m il bl -> BlockSpec m il bl)
-> (BlockNode m il bl -> BlockData m il bl)
-> BlockNode m il bl
-> BlockSpec m il bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel) [BlockNode m il bl]
children)
curline <- SourcePos -> Int
sourceLine (SourcePos -> Int)
-> ParsecT [Tok] (BPState m il bl) m SourcePos
-> ParsecT [Tok] (BPState m il bl) m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
let blanksAtEnd = case [Int]
blanks of
(Int
l:[Int]
_) -> Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
curline Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
[Int]
_ -> Bool
False
let blanksInside = case [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
blanks of
Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> Bool
True
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Bool -> Bool
not Bool
blanksAtEnd
| Bool
otherwise -> Bool
False
let lidata' = ListItemData -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (ListItemData -> Dynamic) -> ListItemData -> Dynamic
forall a b. (a -> b) -> a -> b
$ ListItemData
lidata{ listItemBlanksInside = blanksInside
, listItemBlanksAtEnd = blanksAtEnd }
defaultFinalizer (Node cdata{ blockData = lidata' } children)
parent
}
removeConsecutive :: [Int] -> [Int]
removeConsecutive :: [Int] -> [Int]
removeConsecutive (Int
x:Int
y:[Int]
zs)
| Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 = [Int] -> [Int]
removeConsecutive (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
zs)
removeConsecutive [Int]
xs = [Int]
xs
itemStart :: Monad m
=> BlockParser m il bl (SourcePos, ListItemData)
itemStart :: forall (m :: * -> *) il bl.
Monad m =>
BlockParser m il bl (SourcePos, ListItemData)
itemStart = do
beforecol <- SourcePos -> Int
sourceColumn (SourcePos -> Int)
-> ParsecT [Tok] (BPState m il bl) m SourcePos
-> ParsecT [Tok] (BPState m il bl) m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
gobbleUpToSpaces 3
pos <- getPosition
ty <- bulletListMarker
aftercol <- sourceColumn <$> getPosition
checked <- parseCheckbox
lookAhead whitespace
numspaces <- try (gobbleUpToSpaces 4 <* notFollowedBy whitespace)
<|> gobbleSpaces 1
<|> 1 <$ lookAhead lineEnd
return $! (pos, ListItemData{
listItemType = ty
, listItemChecked = checked
, listItemIndent = (aftercol - beforecol) + numspaces
, listItemBlanksInside = False
, listItemBlanksAtEnd = False
})
parseCheckbox :: Monad m => BlockParser m il bl Bool
parseCheckbox :: forall (m :: * -> *) il bl. Monad m => BlockParser m il bl Bool
parseCheckbox = do
Int -> ParsecT [Tok] (BPState m il bl) m Int
forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces Int
3
Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'['
checked <- (Bool
False Bool
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m Bool
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Tok -> Bool) -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
Spaces))
ParsecT [Tok] (BPState m il bl) m Bool
-> ParsecT [Tok] (BPState m il bl) m Bool
-> ParsecT [Tok] (BPState m il bl) m Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool
True Bool
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m Bool
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Tok -> Bool) -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok ((Text -> Bool) -> Tok -> Bool
textIs (\Text
t -> Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"x" Bool -> Bool -> Bool
|| Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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 :: ListType -> ListSpacing -> [(Bool, Html a)] -> Html a
taskList ListType
lt ListSpacing
spacing [(Bool, Html a)]
items =
Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class",Text
"task-list")
(Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$ ListType -> ListSpacing -> [Html a] -> Html a
forall il b. IsBlock il b => ListType -> ListSpacing -> [b] -> b
list ListType
lt ListSpacing
spacing
([Html a] -> Html a) -> [Html a] -> Html a
forall a b. (a -> b) -> a -> b
$ ((Bool, Html a) -> Html a) -> [(Bool, Html a)] -> [Html a]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Html a) -> Html a
forall a. (Bool, Html a) -> Html a
addCheckbox [(Bool, Html a)]
items
addCheckbox :: (Bool, Html a) -> Html a
addCheckbox :: forall a. (Bool, Html a) -> Html a
addCheckbox (Bool
checked, Html a
x) =
(Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"type", Text
"checkbox") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"disabled", Text
"") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
(if Bool
checked then Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"checked",Text
"") else Html a -> Html a
forall a. a -> a
id) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"input" Maybe (Html a)
forall a. Maybe a
Nothing) Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x
instance (HasTaskList il bl, Semigroup bl, Semigroup il)
=> HasTaskList (WithSourceMap il) (WithSourceMap bl) where
taskList :: ListType
-> ListSpacing -> [(Bool, WithSourceMap bl)] -> WithSourceMap bl
taskList ListType
lt ListSpacing
spacing [(Bool, WithSourceMap bl)]
items =
(do let ([Bool]
checks, [WithSourceMap bl]
xs) = [(Bool, WithSourceMap bl)] -> ([Bool], [WithSourceMap bl])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, WithSourceMap bl)]
items
ListType -> ListSpacing -> [(Bool, bl)] -> bl
forall il bl.
HasTaskList il bl =>
ListType -> ListSpacing -> [(Bool, bl)] -> bl
taskList ListType
lt ListSpacing
spacing ([(Bool, bl)] -> bl) -> ([bl] -> [(Bool, bl)]) -> [bl] -> bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [bl] -> [(Bool, bl)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
checks ([bl] -> bl) -> WithSourceMap [bl] -> WithSourceMap bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WithSourceMap bl] -> WithSourceMap [bl]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [WithSourceMap bl]
xs
) WithSourceMap bl -> WithSourceMap () -> WithSourceMap bl
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"taskList"