{-# LANGUAGE OverloadedStrings #-}
module Cheapskate.Parse (
markdown
) where
import Cheapskate.ParserCombinators
import Cheapskate.Util
import Cheapskate.Inlines
import Cheapskate.Types
import Data.Char hiding (Space)
import qualified Data.Set as Set
import Prelude hiding (takeWhile)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Monoid
import Data.Foldable (toList)
import Data.Sequence ((|>), viewr, ViewR(..), singleton, Seq)
import qualified Data.Sequence as Seq
import Control.Monad.RWS
import Control.Applicative
import qualified Data.Map as M
import Data.List (intercalate)
import Debug.Trace
markdown :: Options -> Text -> Doc
markdown :: Options -> Text -> Doc
markdown opts :: Options
opts
| Options -> Bool
debug Options
opts = (\x :: (Container, ReferenceMap)
x -> String -> Doc -> Doc
forall a. String -> a -> a
trace ((Container, ReferenceMap) -> String
forall a. Show a => a -> String
show (Container, ReferenceMap)
x) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Options -> Blocks -> Doc
Doc Options
opts Blocks
forall a. Monoid a => a
mempty) ((Container, ReferenceMap) -> Doc)
-> (Text -> (Container, ReferenceMap)) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Container, ReferenceMap)
processLines
| Bool
otherwise = Options -> Blocks -> Doc
Doc Options
opts (Blocks -> Doc) -> (Text -> Blocks) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Container, ReferenceMap) -> Blocks
processDocument ((Container, ReferenceMap) -> Blocks)
-> (Text -> (Container, ReferenceMap)) -> Text -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Container, ReferenceMap)
processLines
data ContainerStack =
ContainerStack Container [Container]
type LineNumber = Int
data Elt = C Container
| L LineNumber Leaf
deriving Int -> Elt -> ShowS
[Elt] -> ShowS
Elt -> String
(Int -> Elt -> ShowS)
-> (Elt -> String) -> ([Elt] -> ShowS) -> Show Elt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Elt] -> ShowS
$cshowList :: [Elt] -> ShowS
show :: Elt -> String
$cshow :: Elt -> String
showsPrec :: Int -> Elt -> ShowS
$cshowsPrec :: Int -> Elt -> ShowS
Show
data Container = Container{
Container -> ContainerType
containerType :: ContainerType
, Container -> Seq Elt
children :: Seq Elt
}
data ContainerType = Document
| BlockQuote
| ListItem { ContainerType -> Int
markerColumn :: Int
, ContainerType -> Int
padding :: Int
, ContainerType -> ListType
listType :: ListType }
| FencedCode { ContainerType -> Int
startColumn :: Int
, ContainerType -> Text
fence :: Text
, ContainerType -> Text
info :: Text }
| IndentedCode
| RawHtmlBlock
| Reference
deriving (ContainerType -> ContainerType -> Bool
(ContainerType -> ContainerType -> Bool)
-> (ContainerType -> ContainerType -> Bool) -> Eq ContainerType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContainerType -> ContainerType -> Bool
$c/= :: ContainerType -> ContainerType -> Bool
== :: ContainerType -> ContainerType -> Bool
$c== :: ContainerType -> ContainerType -> Bool
Eq, Int -> ContainerType -> ShowS
[ContainerType] -> ShowS
ContainerType -> String
(Int -> ContainerType -> ShowS)
-> (ContainerType -> String)
-> ([ContainerType] -> ShowS)
-> Show ContainerType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContainerType] -> ShowS
$cshowList :: [ContainerType] -> ShowS
show :: ContainerType -> String
$cshow :: ContainerType -> String
showsPrec :: Int -> ContainerType -> ShowS
$cshowsPrec :: Int -> ContainerType -> ShowS
Show)
instance Show Container where
show :: Container -> String
show c :: Container
c = ContainerType -> String
forall a. Show a => a -> String
show (Container -> ContainerType
containerType Container
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
Int -> ShowS
nest 2 (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ((Elt -> String) -> [Elt] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> String
showElt ([Elt] -> [String]) -> [Elt] -> [String]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Elt -> [Elt]) -> Seq Elt -> [Elt]
forall a b. (a -> b) -> a -> b
$ Container -> Seq Elt
children Container
c))
nest :: Int -> String -> String
nest :: Int -> ShowS
nest num :: Int
num = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
num ' ') String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
showElt :: Elt -> String
showElt :: Elt -> String
showElt (C c :: Container
c) = Container -> String
forall a. Show a => a -> String
show Container
c
showElt (L _ (TextLine s :: Text
s)) = Text -> String
forall a. Show a => a -> String
show Text
s
showElt (L _ lf :: Leaf
lf) = Leaf -> String
forall a. Show a => a -> String
show Leaf
lf
containerContinue :: Container -> Scanner
containerContinue :: Container -> Scanner
containerContinue c :: Container
c =
case Container -> ContainerType
containerType Container
c of
BlockQuote -> Scanner
scanNonindentSpace Scanner -> Scanner -> Scanner
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Scanner
scanBlockquoteStart
IndentedCode -> Scanner
scanIndentSpace
FencedCode{startColumn :: ContainerType -> Int
startColumn = Int
col} ->
Int -> Scanner
scanSpacesToColumn Int
col
RawHtmlBlock -> Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline
li :: ContainerType
li@ListItem{} -> Scanner
scanBlankline
Scanner -> Scanner -> Scanner
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(do Int -> Scanner
scanSpacesToColumn
(ContainerType -> Int
markerColumn ContainerType
li Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
Int -> (Char -> Bool) -> Parser Text
upToCountChars (ContainerType -> Int
padding ContainerType
li Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ')
() -> Scanner
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Reference{} -> Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline Scanner -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Scanner -> Scanner
forall a. Parser a -> Scanner
nfb (Scanner
scanNonindentSpace Scanner -> Scanner -> Scanner
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Scanner
scanReference)
_ -> () -> Scanner
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE containerContinue #-}
containerStart :: Bool -> Parser ContainerType
containerStart :: Bool -> Parser ContainerType
containerStart _lastLineIsText :: Bool
_lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
( (ContainerType
BlockQuote ContainerType -> Scanner -> Parser ContainerType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanBlockquoteStart)
Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ContainerType
parseListMarker
)
verbatimContainerStart :: Bool -> Parser ContainerType
verbatimContainerStart :: Bool -> Parser ContainerType
verbatimContainerStart lastLineIsText :: Bool
lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
( Parser ContainerType
parseCodeFence
Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
IndentedCode ContainerType -> Parser Char -> Parser ContainerType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char ' ' Parser ContainerType -> Scanner -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Scanner -> Scanner
forall a. Parser a -> Scanner
nfb Scanner
scanBlankline))
Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
RawHtmlBlock ContainerType -> Scanner -> Parser ContainerType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
parseHtmlBlockStart))
Parser ContainerType
-> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
lastLineIsText) Scanner -> Parser ContainerType -> Parser ContainerType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ContainerType
Reference ContainerType -> Scanner -> Parser ContainerType
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanReference))
)
data Leaf = TextLine Text
| BlankLine Text
| Int Text
| Int Text
| Rule
deriving (Int -> Leaf -> ShowS
[Leaf] -> ShowS
Leaf -> String
(Int -> Leaf -> ShowS)
-> (Leaf -> String) -> ([Leaf] -> ShowS) -> Show Leaf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Leaf] -> ShowS
$cshowList :: [Leaf] -> ShowS
show :: Leaf -> String
$cshow :: Leaf -> String
showsPrec :: Int -> Leaf -> ShowS
$cshowsPrec :: Int -> Leaf -> ShowS
Show)
type ContainerM = RWS () ReferenceMap ContainerStack
closeStack :: ContainerM Container
closeStack :: ContainerM Container
closeStack = do
ContainerStack top :: Container
top rest :: [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
if [Container] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Container]
rest
then Container -> ContainerM Container
forall (m :: * -> *) a. Monad m => a -> m a
return Container
top
else ContainerM ()
closeContainer ContainerM () -> ContainerM Container -> ContainerM Container
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContainerM Container
closeStack
closeContainer :: ContainerM ()
closeContainer :: ContainerM ()
closeContainer = do
ContainerStack top :: Container
top rest :: [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
case Container
top of
(Container Reference{} cs'' :: Seq Elt
cs'') ->
case Parser (Text, Text, Text)
-> Text -> Either ParseError (Text, Text, Text)
forall a. Parser a -> Text -> Either ParseError a
parse Parser (Text, Text, Text)
pReference
(Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'') of
Right (lab :: Text
lab, lnk :: Text
lnk, tit :: Text
tit) -> do
ReferenceMap -> ContainerM ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> (Text, Text) -> ReferenceMap
forall k a. k -> a -> Map k a
M.singleton (Text -> Text
normalizeReference Text
lab) (Text
lnk, Text
tit))
case [Container]
rest of
(Container ct' :: ContainerType
ct' cs' :: Seq Elt
cs' : rs :: [Container]
rs) ->
ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
[] -> () -> ContainerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Left _ ->
case [Container]
rest of
(c :: Container
c:cs :: [Container]
cs) -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack Container
c [Container]
cs
[] -> () -> ContainerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Container li :: ContainerType
li@ListItem{} cs'' :: Seq Elt
cs'') ->
case [Container]
rest of
(Container ct' :: ContainerType
ct' cs' :: Seq Elt
cs' : rs :: [Container]
rs) ->
case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs'' of
(zs :: Seq Elt
zs :> b :: Elt
b@(L _ BlankLine{})) ->
ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack
(if Seq Elt -> Bool
forall a. Seq a -> Bool
Seq.null Seq Elt
zs
then ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
li Seq Elt
zs))
else ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|>
Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
li Seq Elt
zs) Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Elt
b)) [Container]
rs
_ -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
[] -> () -> ContainerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> case [Container]
rest of
(Container ct' :: ContainerType
ct' cs' :: Seq Elt
cs' : rs :: [Container]
rs) ->
ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct' (Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Container -> Elt
C Container
top)) [Container]
rs
[] -> () -> ContainerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addLeaf :: LineNumber -> Leaf -> ContainerM ()
addLeaf :: Int -> Leaf -> ContainerM ()
addLeaf lineNum :: Int
lineNum lf :: Leaf
lf = do
ContainerStack top :: Container
top rest :: [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
case (Container
top, Leaf
lf) of
(Container ct :: ContainerType
ct@(ListItem{}) cs :: Seq Elt
cs, BlankLine{}) ->
case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
(_ :> L _ BlankLine{}) ->
ContainerM ()
closeContainer ContainerM () -> ContainerM () -> ContainerM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNum Leaf
lf
_ -> ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct (Seq Elt
cs Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNum Leaf
lf)) [Container]
rest
(Container ct :: ContainerType
ct cs :: Seq Elt
cs, _) ->
ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct (Seq Elt
cs Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNum Leaf
lf)) [Container]
rest
addContainer :: ContainerType -> ContainerM ()
addContainer :: ContainerType -> ContainerM ()
addContainer ct :: ContainerType
ct = (ContainerStack -> ContainerStack) -> ContainerM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ContainerStack -> ContainerStack) -> ContainerM ())
-> (ContainerStack -> ContainerStack) -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ \(ContainerStack top :: Container
top rest :: [Container]
rest) ->
Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
forall a. Monoid a => a
mempty) (Container
topContainer -> [Container] -> [Container]
forall a. a -> [a] -> [a]
:[Container]
rest)
processDocument :: (Container, ReferenceMap) -> Blocks
processDocument :: (Container, ReferenceMap) -> Blocks
processDocument (Container ct :: ContainerType
ct cs :: Seq Elt
cs, refmap :: ReferenceMap
refmap) =
case ContainerType
ct of
Document -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap (Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs)
_ -> String -> Blocks
forall a. HasCallStack => String -> a
error "top level container is not Document"
processElts :: ReferenceMap -> [Elt] -> Blocks
processElts :: ReferenceMap -> [Elt] -> Blocks
processElts _ [] = Blocks
forall a. Monoid a => a
mempty
processElts refmap :: ReferenceMap
refmap (L _lineNumber :: Int
_lineNumber lf :: Leaf
lf : rest :: [Elt]
rest) =
case Leaf
lf of
TextLine t :: Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Inlines -> Block
Para (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
where txt :: Text
txt = Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.stripStart
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText [Elt]
textlines
(textlines :: [Elt]
textlines, rest' :: [Elt]
rest') = (Elt -> Bool) -> [Elt] -> ([Elt], [Elt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Elt -> Bool
isTextLine [Elt]
rest
isTextLine :: Elt -> Bool
isTextLine (L _ (TextLine _)) = Bool
True
isTextLine _ = Bool
False
BlankLine{} -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
ATXHeader lvl :: Int
lvl t :: Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Int -> Inlines -> Block
Header Int
lvl (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
SetextHeader lvl :: Int
lvl t :: Text
t -> Block -> Blocks
forall a. a -> Seq a
singleton (Int -> Inlines -> Block
Header Int
lvl (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
Rule -> Block -> Blocks
forall a. a -> Seq a
singleton Block
HRule Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
processElts refmap :: ReferenceMap
refmap (C (Container ct :: ContainerType
ct cs :: Seq Elt
cs) : rest :: [Elt]
rest) =
case ContainerType
ct of
Document -> String -> Blocks
forall a. HasCallStack => String -> a
error "Document container found inside Document"
BlockQuote -> Block -> Blocks
forall a. a -> Seq a
singleton (Blocks -> Block
Blockquote (Blocks -> Block) -> Blocks -> Block
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap (Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs)) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
ListItem { listType :: ContainerType -> ListType
listType = ListType
listType' } ->
Block -> Blocks
forall a. a -> Seq a
singleton (Bool -> ListType -> [Blocks] -> Block
List Bool
isTight ListType
listType' [Blocks]
items') Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
where xs :: [Elt]
xs = [Elt] -> [Elt]
takeListItems [Elt]
rest
rest' :: [Elt]
rest' = Int -> [Elt] -> [Elt]
forall a. Int -> [a] -> [a]
drop ([Elt] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elt]
xs) [Elt]
rest
takeListItems :: [Elt] -> [Elt]
takeListItems
(C c :: Container
c@(Container ListItem { listType :: ContainerType -> ListType
listType = ListType
lt' } _) : zs :: [Elt]
zs)
| ListType -> ListType -> Bool
listTypesMatch ListType
lt' ListType
listType' = Container -> Elt
C Container
c Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt] -> [Elt]
takeListItems [Elt]
zs
takeListItems (lf :: Elt
lf@(L _ (BlankLine _)) :
c :: Elt
c@(C (Container ListItem { listType :: ContainerType -> ListType
listType = ListType
lt' } _)) : zs :: [Elt]
zs)
| ListType -> ListType -> Bool
listTypesMatch ListType
lt' ListType
listType' = Elt
lf Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: Elt
c Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt] -> [Elt]
takeListItems [Elt]
zs
takeListItems _ = []
listTypesMatch :: ListType -> ListType -> Bool
listTypesMatch (Bullet c1 :: Char
c1) (Bullet c2 :: Char
c2) = Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c2
listTypesMatch (Numbered w1 :: NumWrapper
w1 _) (Numbered w2 :: NumWrapper
w2 _) = NumWrapper
w1 NumWrapper -> NumWrapper -> Bool
forall a. Eq a => a -> a -> Bool
== NumWrapper
w2
listTypesMatch _ _ = Bool
False
items :: [[Elt]]
items = (Container -> Maybe [Elt]) -> [Container] -> [[Elt]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Container -> Maybe [Elt]
getItem (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
cs Container -> [Container] -> [Container]
forall a. a -> [a] -> [a]
: [Container
c | C c :: Container
c <- [Elt]
xs])
getItem :: Container -> Maybe [Elt]
getItem (Container ListItem{} cs' :: Seq Elt
cs') = [Elt] -> Maybe [Elt]
forall a. a -> Maybe a
Just ([Elt] -> Maybe [Elt]) -> [Elt] -> Maybe [Elt]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'
getItem _ = Maybe [Elt]
forall a. Maybe a
Nothing
items' :: [Blocks]
items' = ([Elt] -> Blocks) -> [[Elt]] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map (ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap) [[Elt]]
items
isTight :: Bool
isTight = [Elt] -> Bool
tightListItem [Elt]
xs Bool -> Bool -> Bool
&& ([Elt] -> Bool) -> [[Elt]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Elt] -> Bool
tightListItem [[Elt]]
items
FencedCode _ _ info' :: Text
info' -> Block -> Blocks
forall a. a -> Seq a
singleton (CodeAttr -> Text -> Block
CodeBlock CodeAttr
attr Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
where txt :: Text
txt = [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs
attr :: CodeAttr
attr = Text -> Text -> CodeAttr
CodeAttr Text
x (Text -> Text
T.strip Text
y)
(x :: Text
x,y :: Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ') Text
info'
IndentedCode -> Block -> Blocks
forall a. a -> Seq a
singleton (CodeAttr -> Text -> Block
CodeBlock (Text -> Text -> CodeAttr
CodeAttr "" "") Text
txt)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest'
where txt :: Text
txt = [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
stripTrailingEmpties
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Elt -> [Text]) -> [Elt] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Elt -> [Text]
extractCode [Elt]
cbs
stripTrailingEmpties :: [Text] -> [Text]
stripTrailingEmpties = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ')) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
extractCode :: Elt -> [Text]
extractCode (L _ (BlankLine t :: Text
t)) = [Int -> Text -> Text
T.drop 1 Text
t]
extractCode (C (Container IndentedCode cs' :: Seq Elt
cs')) =
(Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText ([Elt] -> [Text]) -> [Elt] -> [Text]
forall a b. (a -> b) -> a -> b
$ Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs'
extractCode _ = []
(cbs :: [Elt]
cbs, rest' :: [Elt]
rest') = (Elt -> Bool) -> [Elt] -> ([Elt], [Elt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Elt -> Bool
isIndentedCodeOrBlank
(Container -> Elt
C (ContainerType -> Seq Elt -> Container
Container ContainerType
ct Seq Elt
cs) Elt -> [Elt] -> [Elt]
forall a. a -> [a] -> [a]
: [Elt]
rest)
isIndentedCodeOrBlank :: Elt -> Bool
isIndentedCodeOrBlank (L _ BlankLine{}) = Bool
True
isIndentedCodeOrBlank (C (Container IndentedCode _))
= Bool
True
isIndentedCodeOrBlank _ = Bool
False
RawHtmlBlock -> Block -> Blocks
forall a. a -> Seq a
singleton (Text -> Block
HtmlBlock Text
txt) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
where txt :: Text
txt = [Text] -> Text
joinLines ((Elt -> Text) -> [Elt] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Elt -> Text
extractText (Seq Elt -> [Elt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Elt
cs))
Reference{} -> ReferenceMap -> [Elt] -> Blocks
processElts ReferenceMap
refmap [Elt]
rest
where isBlankLine :: Elt -> Bool
isBlankLine (L _ BlankLine{}) = Bool
True
isBlankLine _ = Bool
False
tightListItem :: [Elt] -> Bool
tightListItem [] = Bool
True
tightListItem xs :: [Elt]
xs = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Elt -> Bool) -> [Elt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Elt -> Bool
isBlankLine [Elt]
xs
extractText :: Elt -> Text
(L _ (TextLine t :: Text
t)) = Text
t
extractText _ = Text
forall a. Monoid a => a
mempty
processLines :: Text -> (Container, ReferenceMap)
processLines :: Text -> (Container, ReferenceMap)
processLines t :: Text
t = (Container
doc, ReferenceMap
refmap)
where
(doc :: Container
doc, refmap :: ReferenceMap
refmap) = ContainerM Container
-> () -> ContainerStack -> (Container, ReferenceMap)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS (((Int, Text) -> ContainerM ()) -> [(Int, Text)] -> ContainerM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, Text) -> ContainerM ()
processLine [(Int, Text)]
lns ContainerM () -> ContainerM Container -> ContainerM Container
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContainerM Container
closeStack) () ContainerStack
startState
lns :: [(Int, Text)]
lns = [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
tabFilter ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
t)
startState :: ContainerStack
startState = Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
Document Seq Elt
forall a. Monoid a => a
mempty) []
processLine :: (LineNumber, Text) -> ContainerM ()
processLine :: (Int, Text) -> ContainerM ()
processLine (lineNumber :: Int
lineNumber, txt :: Text
txt) = do
ContainerStack top :: Container
top@(Container ct :: ContainerType
ct cs :: Seq Elt
cs) rest :: [Container]
rest <- RWST () ReferenceMap ContainerStack Identity ContainerStack
forall s (m :: * -> *). MonadState s m => m s
get
let (t' :: Text
t', numUnmatched :: Int
numUnmatched) = [Container] -> Text -> (Text, Int)
tryOpenContainers ([Container] -> [Container]
forall a. [a] -> [a]
reverse ([Container] -> [Container]) -> [Container] -> [Container]
forall a b. (a -> b) -> a -> b
$ Container
topContainer -> [Container] -> [Container]
forall a. a -> [a] -> [a]
:[Container]
rest) Text
txt
let lastLineIsText :: Bool
lastLineIsText = Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&&
case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
(_ :> L _ (TextLine _)) -> Bool
True
_ -> Bool
False
case ContainerType
ct of
RawHtmlBlock{} | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')
IndentedCode | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')
FencedCode{ fence :: ContainerType -> Text
fence = Text
fence' } ->
if Text
fence' Text -> Text -> Bool
`T.isPrefixOf` Text
t'
then ContainerM ()
closeContainer
else Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t')
_ -> case Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers Bool
lastLineIsText (Text -> Int
T.length Text
txt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
t') Text
t' of
([], TextLine t :: Text
t)
| Int
numUnmatched Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
, case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
(_ :> L _ (TextLine _)) -> Bool
True
_ -> Bool
False
, ContainerType
ct ContainerType -> ContainerType -> Bool
forall a. Eq a => a -> a -> Bool
/= ContainerType
IndentedCode -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber (Text -> Leaf
TextLine Text
t)
([], SetextHeader lev :: Int
lev _) | Int
numUnmatched Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 ->
case Seq Elt -> ViewR Elt
forall a. Seq a -> ViewR a
viewr Seq Elt
cs of
(cs' :: Seq Elt
cs' :> L _ (TextLine t :: Text
t)) ->
ContainerStack -> ContainerM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ContainerStack -> ContainerM ())
-> ContainerStack -> ContainerM ()
forall a b. (a -> b) -> a -> b
$ Container -> [Container] -> ContainerStack
ContainerStack (ContainerType -> Seq Elt -> Container
Container ContainerType
ct
(Seq Elt
cs' Seq Elt -> Elt -> Seq Elt
forall a. Seq a -> a -> Seq a
|> Int -> Leaf -> Elt
L Int
lineNumber (Int -> Text -> Leaf
SetextHeader Int
lev Text
t))) [Container]
rest
_ -> String -> ContainerM ()
forall a. HasCallStack => String -> a
error "setext header line without preceding text line"
(ns :: [ContainerType]
ns, lf :: Leaf
lf) -> do
Int
-> ContainerM ()
-> RWST () ReferenceMap ContainerStack Identity [()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numUnmatched ContainerM ()
closeContainer
(ContainerType -> ContainerM ())
-> [ContainerType] -> ContainerM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ContainerType -> ContainerM ()
addContainer [ContainerType]
ns
case ([ContainerType] -> [ContainerType]
forall a. [a] -> [a]
reverse [ContainerType]
ns, Leaf
lf) of
(FencedCode{}:_, BlankLine{}) -> () -> ContainerM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Int -> Leaf -> ContainerM ()
addLeaf Int
lineNumber Leaf
lf
tryOpenContainers :: [Container] -> Text -> (Text, Int)
tryOpenContainers :: [Container] -> Text -> (Text, Int)
tryOpenContainers cs :: [Container]
cs t :: Text
t = case Parser (Text, Int) -> Text -> Either ParseError (Text, Int)
forall a. Parser a -> Text -> Either ParseError a
parse ([Scanner] -> Parser (Text, Int)
forall a. [Parser a] -> Parser (Text, Int)
scanners ([Scanner] -> Parser (Text, Int))
-> [Scanner] -> Parser (Text, Int)
forall a b. (a -> b) -> a -> b
$ (Container -> Scanner) -> [Container] -> [Scanner]
forall a b. (a -> b) -> [a] -> [b]
map Container -> Scanner
containerContinue [Container]
cs) Text
t of
Right (t' :: Text
t', n :: Int
n) -> (Text
t', Int
n)
Left e :: ParseError
e -> String -> (Text, Int)
forall a. HasCallStack => String -> a
error (String -> (Text, Int)) -> String -> (Text, Int)
forall a b. (a -> b) -> a -> b
$ "error parsing scanners: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
ParseError -> String
forall a. Show a => a -> String
show ParseError
e
where scanners :: [Parser a] -> Parser (Text, Int)
scanners [] = (,) (Text -> Int -> (Text, Int))
-> Parser Text -> Parser (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText Parser (Int -> (Text, Int)) -> Parser Int -> Parser (Text, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
scanners (p :: Parser a
p:ps :: [Parser a]
ps) = (Parser a
p Parser a -> Parser (Text, Int) -> Parser (Text, Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parser a] -> Parser (Text, Int)
scanners [Parser a]
ps)
Parser (Text, Int) -> Parser (Text, Int) -> Parser (Text, Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((,) (Text -> Int -> (Text, Int))
-> Parser Text -> Parser (Int -> (Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText Parser (Int -> (Text, Int)) -> Parser Int -> Parser (Text, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Parser a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Parser a
pParser a -> [Parser a] -> [Parser a]
forall a. a -> [a] -> [a]
:[Parser a]
ps)))
tryNewContainers :: Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers :: Bool -> Int -> Text -> ([ContainerType], Leaf)
tryNewContainers lastLineIsText :: Bool
lastLineIsText offset :: Int
offset t :: Text
t =
case Parser ([ContainerType], Leaf)
-> Text -> Either ParseError ([ContainerType], Leaf)
forall a. Parser a -> Text -> Either ParseError a
parse Parser ([ContainerType], Leaf)
newContainers Text
t of
Right (cs :: [ContainerType]
cs,t' :: Leaf
t') -> ([ContainerType]
cs, Leaf
t')
Left err :: ParseError
err -> String -> ([ContainerType], Leaf)
forall a. HasCallStack => String -> a
error (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
where newContainers :: Parser ([ContainerType], Leaf)
newContainers = do
Parser Position
getPosition Parser Position -> (Position -> Scanner) -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pos :: Position
pos -> Position -> Scanner
setPosition Position
pos{ column :: Int
column = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
[ContainerType]
regContainers <- Parser ContainerType -> Parser [ContainerType]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> Parser ContainerType
containerStart Bool
lastLineIsText)
[ContainerType]
verbatimContainers <- [ContainerType] -> Parser [ContainerType] -> Parser [ContainerType]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option []
(Parser [ContainerType] -> Parser [ContainerType])
-> Parser [ContainerType] -> Parser [ContainerType]
forall a b. (a -> b) -> a -> b
$ Int -> Parser ContainerType -> Parser [ContainerType]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count 1 (Bool -> Parser ContainerType
verbatimContainerStart Bool
lastLineIsText)
if [ContainerType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ContainerType]
verbatimContainers
then (,) ([ContainerType] -> Leaf -> ([ContainerType], Leaf))
-> Parser [ContainerType]
-> Parser (Leaf -> ([ContainerType], Leaf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ContainerType] -> Parser [ContainerType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ContainerType]
regContainers Parser (Leaf -> ([ContainerType], Leaf))
-> Parser Leaf -> Parser ([ContainerType], Leaf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Parser Leaf
leaf Bool
lastLineIsText
else (,) ([ContainerType] -> Leaf -> ([ContainerType], Leaf))
-> Parser [ContainerType]
-> Parser (Leaf -> ([ContainerType], Leaf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ContainerType] -> Parser [ContainerType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ContainerType]
regContainers [ContainerType] -> [ContainerType] -> [ContainerType]
forall a. [a] -> [a] -> [a]
++ [ContainerType]
verbatimContainers) Parser (Leaf -> ([ContainerType], Leaf))
-> Parser Leaf -> Parser ([ContainerType], Leaf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Parser Leaf
textLineOrBlank
textLineOrBlank :: Parser Leaf
textLineOrBlank :: Parser Leaf
textLineOrBlank = Text -> Leaf
consolidate (Text -> Leaf) -> Parser Text -> Parser Leaf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText
where consolidate :: Text -> Leaf
consolidate ts :: Text
ts | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ') Text
ts = Text -> Leaf
BlankLine Text
ts
| Bool
otherwise = Text -> Leaf
TextLine Text
ts
leaf :: Bool -> Parser Leaf
leaf :: Bool -> Parser Leaf
leaf lastLineIsText :: Bool
lastLineIsText = Scanner
scanNonindentSpace Scanner -> Parser Leaf -> Parser Leaf
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (
(Int -> Text -> Leaf
ATXHeader (Int -> Text -> Leaf) -> Parser Int -> Parser (Text -> Leaf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseAtxHeaderStart Parser (Text -> Leaf) -> Parser Text -> Parser Leaf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
(Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
removeATXSuffix (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText))
Parser Leaf -> Parser Leaf -> Parser Leaf
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
lastLineIsText Scanner -> Parser Leaf -> Parser Leaf
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> Text -> Leaf
SetextHeader (Int -> Text -> Leaf) -> Parser Int -> Parser (Text -> Leaf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseSetextHeaderLine Parser (Text -> Leaf) -> Parser Text -> Parser Leaf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty))
Parser Leaf -> Parser Leaf -> Parser Leaf
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Leaf
Rule Leaf -> Scanner -> Parser Leaf
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanHRuleLine)
Parser Leaf -> Parser Leaf -> Parser Leaf
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Leaf
textLineOrBlank
)
where removeATXSuffix :: Text -> Text
removeATXSuffix t :: Text
t = case (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (" #" :: String)) Text
t of
t' :: Text
t' | Text -> Bool
T.null Text
t' -> Text
t'
| Text -> Char
T.last Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' -> Text
t' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "#"
| Bool
otherwise -> Text
t'
scanReference :: Scanner
scanReference :: Scanner
scanReference = () () -> Scanner -> Scanner
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner -> Scanner
forall a. Parser a -> Parser a
lookAhead (Parser Text
pLinkLabel Parser Text -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Scanner
scanChar ':')
scanBlockquoteStart :: Scanner
scanBlockquoteStart :: Scanner
scanBlockquoteStart = Char -> Scanner
scanChar '>' Scanner -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Scanner -> Scanner
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (Char -> Scanner
scanChar ' ')
parseAtxHeaderStart :: Parser Int
= do
Char -> Parser Char
char '#'
Text
hashes <- Int -> (Char -> Bool) -> Parser Text
upToCountChars 5 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#')
Scanner -> Scanner
forall a. Parser a -> Scanner
notFollowedBy ((Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' '))
Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
hashes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
parseSetextHeaderLine :: Parser Int
= do
Char
d <- (Char -> Bool) -> Parser Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=')
let lev :: Int
lev = if Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=' then 1 else 2
(Char -> Bool) -> Scanner
skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d)
Scanner
scanBlankline
Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lev
scanHRuleLine :: Scanner
scanHRuleLine :: Scanner
scanHRuleLine = do
Char
c <- (Char -> Bool) -> Parser Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-')
Int -> Scanner -> Parser [()]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count 2 (Scanner -> Parser [()]) -> Scanner -> Parser [()]
forall a b. (a -> b) -> a -> b
$ Scanner
scanSpaces Scanner -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
(Char -> Bool) -> Scanner
skipWhile (\x :: Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
Scanner
endOfInput
parseCodeFence :: Parser ContainerType
parseCodeFence :: Parser ContainerType
parseCodeFence = do
Int
col <- Position -> Int
column (Position -> Int) -> Parser Position -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Position
getPosition
Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='`') Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='~')
Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 3
Scanner
scanSpaces
Text
rawattr <- (Char -> Bool) -> Parser Text
takeWhile (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '`' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '~')
Scanner
endOfInput
ContainerType -> Parser ContainerType
forall (m :: * -> *) a. Monad m => a -> m a
return (ContainerType -> Parser ContainerType)
-> ContainerType -> Parser ContainerType
forall a b. (a -> b) -> a -> b
$ FencedCode :: Int -> Text -> Text -> ContainerType
FencedCode { startColumn :: Int
startColumn = Int
col
, fence :: Text
fence = Text
cs
, info :: Text
info = Text
rawattr }
parseHtmlBlockStart :: Parser ()
parseHtmlBlockStart :: Scanner
parseHtmlBlockStart = () () -> Parser Text -> Scanner
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text -> Parser Text
forall a. Parser a -> Parser a
lookAhead
((do (HtmlTagType, Text)
t <- Parser (HtmlTagType, Text)
pHtmlTag
Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ HtmlTagType -> Bool
f (HtmlTagType -> Bool) -> HtmlTagType -> Bool
forall a b. (a -> b) -> a -> b
$ (HtmlTagType, Text) -> HtmlTagType
forall a b. (a, b) -> a
fst (HtmlTagType, Text)
t
Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ (HtmlTagType, Text) -> Text
forall a b. (a, b) -> b
snd (HtmlTagType, Text)
t)
Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
string "<!--"
Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
string "-->"
)
where f :: HtmlTagType -> Bool
f (Opening name :: Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags
f (SelfClosing name :: Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags
f (Closing name :: Text
name) = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
blockHtmlTags
blockHtmlTags :: Set.Set Text
blockHtmlTags :: Set Text
blockHtmlTags = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ "article", "header", "aside", "hgroup", "blockquote", "hr",
"body", "li", "br", "map", "button", "object", "canvas", "ol",
"caption", "output", "col", "p", "colgroup", "pre", "dd",
"progress", "div", "section", "dl", "table", "dt", "tbody",
"embed", "textarea", "fieldset", "tfoot", "figcaption", "th",
"figure", "thead", "footer", "footer", "tr", "form", "ul",
"h1", "h2", "h3", "h4", "h5", "h6", "video"]
parseListMarker :: Parser ContainerType
parseListMarker :: Parser ContainerType
parseListMarker = do
Int
col <- Position -> Int
column (Position -> Int) -> Parser Position -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Position
getPosition
ListType
ty <- Parser ListType
parseBullet Parser ListType -> Parser ListType -> Parser ListType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ListType
parseListNumber
Int
padding' <- (1 Int -> Scanner -> Parser Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Scanner
scanBlankline)
Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (1 Int -> Parser String -> Parser Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ') Scanner -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String -> Parser String
forall a. Parser a -> Parser a
lookAhead (Int -> Parser Char -> Parser String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count 4 (Char -> Parser Char
char ' '))))
Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Int
T.length (Text -> Int) -> Parser Text -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' '))
Bool -> Scanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Scanner) -> Bool -> Scanner
forall a b. (a -> b) -> a -> b
$ Int
padding' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
ContainerType -> Parser ContainerType
forall (m :: * -> *) a. Monad m => a -> m a
return (ContainerType -> Parser ContainerType)
-> ContainerType -> Parser ContainerType
forall a b. (a -> b) -> a -> b
$ ListItem :: Int -> Int -> ListType -> ContainerType
ListItem { listType :: ListType
listType = ListType
ty
, markerColumn :: Int
markerColumn = Int
col
, padding :: Int
padding = Int
padding' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ListType -> Int
listMarkerWidth ListType
ty
}
listMarkerWidth :: ListType -> Int
listMarkerWidth :: ListType -> Int
listMarkerWidth (Bullet _) = 1
listMarkerWidth (Numbered _ n :: Int
n) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 10 = 2
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 100 = 3
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1000 = 4
| Bool
otherwise = 5
parseBullet :: Parser ListType
parseBullet :: Parser ListType
parseBullet = do
Char
c <- (Char -> Bool) -> Parser Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-')
Bool -> Scanner -> Scanner
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+')
(Scanner -> Scanner) -> Scanner -> Scanner
forall a b. (a -> b) -> a -> b
$ Scanner -> Scanner
forall a. Parser a -> Scanner
nfb (Scanner -> Scanner) -> Scanner -> Scanner
forall a b. (a -> b) -> a -> b
$ (Int -> Scanner -> Parser [()]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count 2 (Scanner -> Parser [()]) -> Scanner -> Parser [()]
forall a b. (a -> b) -> a -> b
$ Scanner
scanSpaces Scanner -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)) Parser [()] -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
(Char -> Bool) -> Scanner
skipWhile (\x :: Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Scanner -> Scanner -> Scanner
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Scanner
endOfInput
ListType -> Parser ListType
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> Parser ListType) -> ListType -> Parser ListType
forall a b. (a -> b) -> a -> b
$ Char -> ListType
Bullet Char
c
parseListNumber :: Parser ListType
parseListNumber :: Parser ListType
parseListNumber = do
Int
num <- (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (Text -> String) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> Int) -> Parser Text -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
NumWrapper
wrap <- NumWrapper
PeriodFollowing NumWrapper -> Scanner -> Parser NumWrapper
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.')
Parser NumWrapper -> Parser NumWrapper -> Parser NumWrapper
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NumWrapper
ParenFollowing NumWrapper -> Scanner -> Parser NumWrapper
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Scanner
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')')
ListType -> Parser ListType
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> Parser ListType) -> ListType -> Parser ListType
forall a b. (a -> b) -> a -> b
$ NumWrapper -> Int -> ListType
Numbered NumWrapper
wrap Int
num