module Text.Pandoc.Readers.Docx.Reducible ( concatReduce
, (<+>)
)
where
import Text.Pandoc.Builder
import Data.List
import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr)
import qualified Data.Sequence as Seq (null)
data Modifier a = Modifier (a -> a)
| AttrModifier (Attr -> a -> a) Attr
| NullModifier
class (Eq a) => Modifiable a where
modifier :: a -> Modifier a
innards :: a -> a
getL :: a -> (a, a)
getR :: a -> (a, a)
spaceOut :: a -> (a, a, a)
spaceOutL :: (Monoid a, Modifiable a) => a -> (a, a)
spaceOutL ms = (l, stack fs (m' <> r))
where (l, m, r) = spaceOut ms
(fs, m') = unstack m
spaceOutR :: (Monoid a, Modifiable a) => a -> (a, a)
spaceOutR ms = (stack fs (l <> m'), r)
where (l, m, r) = spaceOut ms
(fs, m') = unstack m
instance (Monoid a, Show a) => Show (Modifier a) where
show (Modifier f) = show $ f mempty
show (AttrModifier f attr) = show $ f attr mempty
show (NullModifier) = "NullModifier"
instance (Monoid a, Eq a) => Eq (Modifier a) where
(Modifier f) == (Modifier g) = (f mempty == g mempty)
(AttrModifier f attr) == (AttrModifier g attr') = (f attr mempty == g attr' mempty)
(NullModifier) == (NullModifier) = True
_ == _ = False
instance Modifiable Inlines where
modifier ils = case viewl (unMany ils) of
(x :< xs) | Seq.null xs -> case x of
(Emph _) -> Modifier emph
(Strong _) -> Modifier strong
(SmallCaps _) -> Modifier smallcaps
(Strikeout _) -> Modifier strikeout
(Superscript _) -> Modifier superscript
(Subscript _) -> Modifier subscript
(Span attr _) -> AttrModifier spanWith attr
_ -> NullModifier
_ -> NullModifier
innards ils = case viewl (unMany ils) of
(x :< xs) | Seq.null xs -> case x of
(Emph lst) -> fromList lst
(Strong lst) -> fromList lst
(SmallCaps lst) -> fromList lst
(Strikeout lst) -> fromList lst
(Superscript lst) -> fromList lst
(Subscript lst) -> fromList lst
(Span _ lst) -> fromList lst
_ -> ils
_ -> ils
getL ils = case viewl $ unMany ils of
(s :< sq) -> (singleton s, Many sq)
_ -> (mempty, ils)
getR ils = case viewr $ unMany ils of
(sq :> s) -> (Many sq, singleton s)
_ -> (ils, mempty)
spaceOut ils =
let (fs, ils') = unstack ils
contents = unMany ils'
left = case viewl contents of
(Space :< _) -> space
_ -> mempty
right = case viewr contents of
(_ :> Space) -> space
_ -> mempty in
(left, (stack fs $ trimInlines .Many $ contents), right)
instance Modifiable Blocks where
modifier blks = case viewl (unMany blks) of
(x :< xs) | Seq.null xs -> case x of
(BlockQuote _) -> Modifier blockQuote
_ -> NullModifier
_ -> NullModifier
innards blks = case viewl (unMany blks) of
(x :< xs) | Seq.null xs -> case x of
(BlockQuote lst) -> fromList lst
_ -> blks
_ -> blks
spaceOut blks = (mempty, blks, mempty)
getL ils = case viewl $ unMany ils of
(s :< sq) -> (singleton s, Many sq)
_ -> (mempty, ils)
getR ils = case viewr $ unMany ils of
(sq :> s) -> (Many sq, singleton s)
_ -> (ils, mempty)
unstack :: (Modifiable a) => a -> ([Modifier a], a)
unstack ms = case modifier ms of
NullModifier -> ([], ms)
_ -> (f : fs, ms') where
f = modifier ms
(fs, ms') = unstack $ innards ms
stack :: (Monoid a, Modifiable a) => [Modifier a] -> a -> a
stack [] ms = ms
stack (NullModifier : fs) ms = stack fs ms
stack ((Modifier f) : fs) ms =
if isEmpty ms
then stack fs ms
else f $ stack fs ms
stack ((AttrModifier f attr) : fs) ms = f attr $ stack fs ms
isEmpty :: (Monoid a, Eq a) => a -> Bool
isEmpty x = x == mempty
combine :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
combine x y =
let (xs', x') = getR x
(y', ys') = getL y
in
xs' <> (combineSingleton x' y') <> ys'
isAttrModifier :: Modifier a -> Bool
isAttrModifier (AttrModifier _ _) = True
isAttrModifier _ = False
combineSingleton :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
combineSingleton x y =
let (xfs, xs) = unstack x
(yfs, ys) = unstack y
shared = xfs `intersect` yfs
x_remaining = xfs \\ shared
y_remaining = yfs \\ shared
x_rem_attr = filter isAttrModifier x_remaining
y_rem_attr = filter isAttrModifier y_remaining
in
case null shared of
True | isEmpty xs && isEmpty ys ->
stack (x_rem_attr ++ y_rem_attr) mempty
| isEmpty xs ->
let (sp, y') = spaceOutL y in
(stack x_rem_attr mempty) <> sp <> y'
| isEmpty ys ->
let (x', sp) = spaceOutR x in
x' <> sp <> (stack y_rem_attr mempty)
| otherwise ->
let (x', xsp) = spaceOutR x
(ysp, y') = spaceOutL y
in
x' <> xsp <> ysp <> y'
False -> stack shared $
combine
(stack x_remaining xs)
(stack y_remaining ys)
(<+>) :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
x <+> y = combine x y
concatReduce :: (Monoid a, Modifiable a) => [a] -> a
concatReduce xs = foldl combine mempty xs