{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Text.CommonMark.Sub
    ( HeadingPattern (..)
    , HeadingTitlePattern (..)
    , Level
    , extractSection
    , flattenInlineNodes
    , matchesHeading
    ) where

import Prelude hiding (concat)

import CMark
import Data.Text (Text, concat, pack, strip, toLower)
import Text.Regex.TDFA
import Text.Regex.TDFA.Text

data HeadingPattern = HeadingPattern
    { HeadingPattern -> Level
headingLevel :: Level
    , HeadingPattern -> Bool
caseInsensitive :: Bool
    , HeadingPattern -> HeadingTitlePattern
titlePattern :: HeadingTitlePattern
    } deriving (HeadingPattern -> HeadingPattern -> Bool
(HeadingPattern -> HeadingPattern -> Bool)
-> (HeadingPattern -> HeadingPattern -> Bool) -> Eq HeadingPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeadingPattern -> HeadingPattern -> Bool
$c/= :: HeadingPattern -> HeadingPattern -> Bool
== :: HeadingPattern -> HeadingPattern -> Bool
$c== :: HeadingPattern -> HeadingPattern -> Bool
Eq, Eq HeadingPattern
Eq HeadingPattern
-> (HeadingPattern -> HeadingPattern -> Ordering)
-> (HeadingPattern -> HeadingPattern -> Bool)
-> (HeadingPattern -> HeadingPattern -> Bool)
-> (HeadingPattern -> HeadingPattern -> Bool)
-> (HeadingPattern -> HeadingPattern -> Bool)
-> (HeadingPattern -> HeadingPattern -> HeadingPattern)
-> (HeadingPattern -> HeadingPattern -> HeadingPattern)
-> Ord HeadingPattern
HeadingPattern -> HeadingPattern -> Bool
HeadingPattern -> HeadingPattern -> Ordering
HeadingPattern -> HeadingPattern -> HeadingPattern
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HeadingPattern -> HeadingPattern -> HeadingPattern
$cmin :: HeadingPattern -> HeadingPattern -> HeadingPattern
max :: HeadingPattern -> HeadingPattern -> HeadingPattern
$cmax :: HeadingPattern -> HeadingPattern -> HeadingPattern
>= :: HeadingPattern -> HeadingPattern -> Bool
$c>= :: HeadingPattern -> HeadingPattern -> Bool
> :: HeadingPattern -> HeadingPattern -> Bool
$c> :: HeadingPattern -> HeadingPattern -> Bool
<= :: HeadingPattern -> HeadingPattern -> Bool
$c<= :: HeadingPattern -> HeadingPattern -> Bool
< :: HeadingPattern -> HeadingPattern -> Bool
$c< :: HeadingPattern -> HeadingPattern -> Bool
compare :: HeadingPattern -> HeadingPattern -> Ordering
$ccompare :: HeadingPattern -> HeadingPattern -> Ordering
$cp1Ord :: Eq HeadingPattern
Ord, Level -> HeadingPattern -> ShowS
[HeadingPattern] -> ShowS
HeadingPattern -> String
(Level -> HeadingPattern -> ShowS)
-> (HeadingPattern -> String)
-> ([HeadingPattern] -> ShowS)
-> Show HeadingPattern
forall a.
(Level -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeadingPattern] -> ShowS
$cshowList :: [HeadingPattern] -> ShowS
show :: HeadingPattern -> String
$cshow :: HeadingPattern -> String
showsPrec :: Level -> HeadingPattern -> ShowS
$cshowsPrec :: Level -> HeadingPattern -> ShowS
Show)

data HeadingTitlePattern
    = HeadingTitleRegex Text
    | HeadingTitleText Text
    deriving (HeadingTitlePattern -> HeadingTitlePattern -> Bool
(HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> (HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> Eq HeadingTitlePattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c/= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
== :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c== :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
Eq, Eq HeadingTitlePattern
Eq HeadingTitlePattern
-> (HeadingTitlePattern -> HeadingTitlePattern -> Ordering)
-> (HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> (HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> (HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> (HeadingTitlePattern -> HeadingTitlePattern -> Bool)
-> (HeadingTitlePattern
    -> HeadingTitlePattern -> HeadingTitlePattern)
-> (HeadingTitlePattern
    -> HeadingTitlePattern -> HeadingTitlePattern)
-> Ord HeadingTitlePattern
HeadingTitlePattern -> HeadingTitlePattern -> Bool
HeadingTitlePattern -> HeadingTitlePattern -> Ordering
HeadingTitlePattern -> HeadingTitlePattern -> HeadingTitlePattern
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HeadingTitlePattern -> HeadingTitlePattern -> HeadingTitlePattern
$cmin :: HeadingTitlePattern -> HeadingTitlePattern -> HeadingTitlePattern
max :: HeadingTitlePattern -> HeadingTitlePattern -> HeadingTitlePattern
$cmax :: HeadingTitlePattern -> HeadingTitlePattern -> HeadingTitlePattern
>= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c>= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
> :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c> :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
<= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c<= :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
< :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
$c< :: HeadingTitlePattern -> HeadingTitlePattern -> Bool
compare :: HeadingTitlePattern -> HeadingTitlePattern -> Ordering
$ccompare :: HeadingTitlePattern -> HeadingTitlePattern -> Ordering
$cp1Ord :: Eq HeadingTitlePattern
Ord, Level -> HeadingTitlePattern -> ShowS
[HeadingTitlePattern] -> ShowS
HeadingTitlePattern -> String
(Level -> HeadingTitlePattern -> ShowS)
-> (HeadingTitlePattern -> String)
-> ([HeadingTitlePattern] -> ShowS)
-> Show HeadingTitlePattern
forall a.
(Level -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeadingTitlePattern] -> ShowS
$cshowList :: [HeadingTitlePattern] -> ShowS
show :: HeadingTitlePattern -> String
$cshow :: HeadingTitlePattern -> String
showsPrec :: Level -> HeadingTitlePattern -> ShowS
$cshowsPrec :: Level -> HeadingTitlePattern -> ShowS
Show)

extractSection :: HeadingPattern -> Node -> Node
extractSection :: HeadingPattern -> Node -> Node
extractSection pat :: HeadingPattern
pat@HeadingPattern { Level
headingLevel :: Level
headingLevel :: HeadingPattern -> Level
headingLevel } (Node Maybe PosInfo
pos NodeType
DOCUMENT [Node]
nodes) =
    Maybe PosInfo -> NodeType -> [Node] -> Node
Node Maybe PosInfo
pos NodeType
DOCUMENT ([Node] -> Node) -> [Node] -> Node
forall a b. (a -> b) -> a -> b
$ case [Node]
headlessNodes of
        (Node
x : [Node]
xs) -> Node
x Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Node -> Bool
isInSection [Node]
xs
        [] -> []
  where
    isInSection :: Node -> Bool
    isInSection :: Node -> Bool
isInSection (Node Maybe PosInfo
_ (HEADING Level
lv) [Node]
_) = Level
lv Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
> Level
headingLevel
    isInSection Node
_ = Bool
True
    headlessNodes :: [Node]
    headlessNodes :: [Node]
headlessNodes =
        (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Node -> Bool) -> Node -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadingPattern -> Node -> Bool
matchesHeading HeadingPattern
pat) [Node]
nodes
extractSection HeadingPattern
_ (Node Maybe PosInfo
pos NodeType
_ [Node]
_) = Maybe PosInfo -> NodeType -> [Node] -> Node
Node Maybe PosInfo
pos NodeType
DOCUMENT []

matchesHeading :: HeadingPattern -> Node -> Bool
matchesHeading :: HeadingPattern -> Node -> Bool
matchesHeading HeadingPattern { Level
headingLevel :: Level
headingLevel :: HeadingPattern -> Level
headingLevel
                              , Bool
caseInsensitive :: Bool
caseInsensitive :: HeadingPattern -> Bool
caseInsensitive
                              , HeadingTitlePattern
titlePattern :: HeadingTitlePattern
titlePattern :: HeadingPattern -> HeadingTitlePattern
titlePattern
                              } = case HeadingTitlePattern
titlePattern of
    HeadingTitleText Text
text -> if Bool
caseInsensitive
        then \ case
            (Node Maybe PosInfo
_ (HEADING Level
lv) [Node]
nodes) ->
                Level
lv Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
headingLevel Bool -> Bool -> Bool
&&
                    Text -> Text
toLower ([Node] -> Text
flattenInlineNodes [Node]
nodes) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
toLower Text
text
            Node
_ -> Bool
False
        else \ case
            (Node Maybe PosInfo
_ (HEADING Level
lv) [Node]
nodes) ->
                Level
lv Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
headingLevel Bool -> Bool -> Bool
&& [Node] -> Text
flattenInlineNodes [Node]
nodes Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
text
            Node
_ -> Bool
False
    HeadingTitleRegex Text
regexPat ->
        let compOption :: CompOption
compOption = CompOption :: Bool -> Bool -> Bool -> Bool -> Bool -> CompOption
CompOption
                { caseSensitive :: Bool
caseSensitive = Bool -> Bool
not Bool
caseInsensitive
                , multiline :: Bool
multiline = Bool
False
                , rightAssoc :: Bool
rightAssoc = Bool
True
                , newSyntax :: Bool
newSyntax = Bool
True
                , lastStarGreedy :: Bool
lastStarGreedy = Bool
True
                }
            execOption :: ExecOption
execOption = ExecOption :: Bool -> ExecOption
ExecOption { captureGroups :: Bool
captureGroups = Bool
False }
            regex' :: Either String Regex
regex' = CompOption -> ExecOption -> Text -> Either String Regex
compile CompOption
compOption ExecOption
execOption Text
regexPat
        in
            case Either String Regex
regex' of
                Left String
_ -> Bool -> Node -> Bool
forall a b. a -> b -> a
const Bool
False
                Right Regex
regex ->
                    \ case
                    (Node Maybe PosInfo
_ (HEADING Level
lv) [Node]
nodes) ->
                        Level
lv Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
== Level
headingLevel Bool -> Bool -> Bool
&&
                            case Regex -> Text -> Either String (Maybe MatchArray)
execute Regex
regex ([Node] -> Text
flattenInlineNodes [Node]
nodes) of
                                Right (Just MatchArray
_) -> Bool
True
                                Either String (Maybe MatchArray)
_ -> Bool
False
                    Node
_ -> Bool
False

flattenInlineNodes :: [Node] -> Text
flattenInlineNodes :: [Node] -> Text
flattenInlineNodes =
    Text -> Text
strip (Text -> Text) -> ([Node] -> Text) -> [Node] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
concat ([Text] -> Text) -> ([Node] -> [Text]) -> [Node] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Text) -> [Node] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Text
flatten
  where
    flatten :: Node -> Text
    flatten :: Node -> Text
flatten (Node Maybe PosInfo
_ (TEXT Text
text) [Node]
_) = Text
text
    flatten (Node Maybe PosInfo
_ NodeType
LINEBREAK [Node]
_) = String -> Text
pack String
"\n"
    flatten (Node Maybe PosInfo
_ (HTML_INLINE Text
text) [Node]
_) = Text
text
    flatten (Node Maybe PosInfo
_ (CODE Text
text) [Node]
_) = Text
text
    flatten (Node Maybe PosInfo
_ NodeType
_ [Node]
nodes) = [Node] -> Text
flattenInlineNodes [Node]
nodes