aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Text/Pandoc/Readers/Docx/Reducible.hs150
1 files changed, 150 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Docx/Reducible.hs b/src/Text/Pandoc/Readers/Docx/Reducible.hs
new file mode 100644
index 000000000..1ed31ebd0
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Docx/Reducible.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Pandoc.Readers.Docx.Reducible ((<++>),
+ (<+++>),
+ Reducible,
+ Container(..),
+ container,
+ innards,
+ reduceList,
+ reduceListB,
+ rebuild)
+ where
+
+import Text.Pandoc.Builder
+import Data.List ((\\), intersect)
+
+data Container a = Container ([a] -> a) | NullContainer
+
+instance (Eq a) => Eq (Container a) where
+ (Container x) == (Container y) = ((x []) == (y []))
+ NullContainer == NullContainer = True
+ _ == _ = False
+
+instance (Show a) => Show (Container a) where
+ show (Container x) = "Container {" ++
+ (reverse $ drop 3 $ reverse $ show $ x []) ++
+ "}"
+ show (NullContainer) = "NullContainer"
+
+class Reducible a where
+ (<++>) :: a -> a -> [a]
+ container :: a -> Container a
+ innards :: a -> [a]
+ isSpace :: a -> Bool
+
+(<+++>) :: (Reducible a) => Many a -> Many a -> Many a
+mr <+++> ms = fromList $ reduceList $ toList mr ++ toList ms
+
+reduceListB :: (Reducible a) => Many a -> Many a
+reduceListB = fromList . reduceList . toList
+
+reduceList' :: (Reducible a) => [a] -> [a] -> [a]
+reduceList' acc [] = acc
+reduceList' [] (x:xs) = reduceList' [x] xs
+reduceList' as (x:xs) = reduceList' (init as ++ (last as <++> x) ) xs
+
+reduceList :: (Reducible a) => [a] -> [a]
+reduceList = reduceList' []
+
+combineReducibles :: (Reducible a, Eq a) => a -> a -> [a]
+combineReducibles r s =
+ let (conts, rs) = topLevelContainers r
+ (conts', ss) = topLevelContainers s
+ shared = conts `intersect` conts'
+ remaining = conts \\ shared
+ remaining' = conts' \\ shared
+ in
+ case null shared of
+ True -> case (not . null) rs && isSpace (last rs) of
+ True -> rebuild conts (init rs) ++ [last rs, s]
+ False -> [r,s]
+ False -> rebuild
+ shared $
+ reduceList $
+ (rebuild remaining rs) ++ (rebuild remaining' ss)
+
+instance Reducible Inline where
+ s1@(Span (id1, classes1, kvs1) ils1) <++> s2@(Span (id2, classes2, kvs2) ils2) =
+ let classes' = classes1 `intersect` classes2
+ kvs' = kvs1 `intersect` kvs2
+ classes1' = classes1 \\ classes'
+ kvs1' = kvs1 \\ kvs'
+ classes2' = classes2 \\ classes'
+ kvs2' = kvs2 \\ kvs'
+ in
+ case null classes' && null kvs' of
+ True -> [s1,s2]
+ False -> let attr' = ("", classes', kvs')
+ attr1' = (id1, classes1', kvs1')
+ attr2' = (id2, classes2', kvs2')
+ s1' = case null classes1' && null kvs1' of
+ True -> ils1
+ False -> [Span attr1' ils1]
+ s2' = case null classes2' && null kvs2' of
+ True -> ils2
+ False -> [Span attr2' ils2]
+ in
+ [Span attr' $ reduceList $ s1' ++ s2']
+
+ (Str x) <++> (Str y) = [Str (x++y)]
+ il <++> il' = combineReducibles il il'
+
+ container (Emph _) = Container Emph
+ container (Strong _) = Container Strong
+ container (Strikeout _) = Container Strikeout
+ container (Subscript _) = Container Subscript
+ container (Superscript _) = Container Superscript
+ container (Quoted qt _) = Container $ Quoted qt
+ container (Cite cs _) = Container $ Cite cs
+ container (Span attr _) = Container $ Span attr
+ container _ = NullContainer
+
+ innards (Emph ils) = ils
+ innards (Strong ils) = ils
+ innards (Strikeout ils) = ils
+ innards (Subscript ils) = ils
+ innards (Superscript ils) = ils
+ innards (Quoted _ ils) = ils
+ innards (Cite _ ils) = ils
+ innards (Span _ ils) = ils
+ innards _ = []
+
+ isSpace Space = True
+ isSpace _ = False
+
+instance Reducible Block where
+ (Div (ident, classes, kvs) blks) <++> blk | "list-item" `elem` classes =
+ [Div (ident, classes, kvs) (reduceList blks), blk]
+
+ blk <++> blk' = combineReducibles blk blk'
+
+ container (BlockQuote _) = Container BlockQuote
+ container (Div attr _) = Container $ Div attr
+ container _ = NullContainer
+
+ innards (BlockQuote bs) = bs
+ innards (Div _ bs) = bs
+ innards _ = []
+
+ isSpace _ = False
+
+
+topLevelContainers' :: (Reducible a) => [a] -> ([Container a], [a])
+topLevelContainers' (r : []) = case container r of
+ NullContainer -> ([], [r])
+ _ ->
+ let (conts, inns) = topLevelContainers' (innards r)
+ in
+ ((container r) : conts, inns)
+topLevelContainers' rs = ([], rs)
+
+topLevelContainers :: (Reducible a) => a -> ([Container a], [a])
+topLevelContainers il = topLevelContainers' [il]
+
+rebuild :: [Container a] -> [a] -> [a]
+rebuild [] xs = xs
+rebuild ((Container f) : cs) xs = rebuild cs $ [f xs]
+rebuild (NullContainer : cs) xs = rebuild cs $ xs
+
+