git.iko.soy/typeable/pandoc
on master help sign in
Add new typeclass, Reducible
ef5fad2Jesse Rosenthal
src/Text/Pandoc/Readers/Docx/Reducible.hsnew file+150
compare with master
unifiedsplit
@@ -0,0 +1,150 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Text.Pandoc.Readers.Docx.Reducible ((<++>),
4+ (<+++>),
5+ Reducible,
6+ Container(..),
7+ container,
8+ innards,
9+ reduceList,
10+ reduceListB,
11+ rebuild)
12+ where
13+
14+import Text.Pandoc.Builder
15+import Data.List ((\\), intersect)
16+
17+data Container a = Container ([a] -> a) | NullContainer
18+
19+instance (Eq a) => Eq (Container a) where
20+ (Container x) == (Container y) = ((x []) == (y []))
21+ NullContainer == NullContainer = True
22+ _ == _ = False
23+
24+instance (Show a) => Show (Container a) where
25+ show (Container x) = "Container {" ++
26+ (reverse $ drop 3 $ reverse $ show $ x []) ++
27+ "}"
28+ show (NullContainer) = "NullContainer"
29+
30+class Reducible a where
31+ (<++>) :: a -> a -> [a]
32+ container :: a -> Container a
33+ innards :: a -> [a]
34+ isSpace :: a -> Bool
35+
36+(<+++>) :: (Reducible a) => Many a -> Many a -> Many a
37+mr <+++> ms = fromList $ reduceList $ toList mr ++ toList ms
38+
39+reduceListB :: (Reducible a) => Many a -> Many a
40+reduceListB = fromList . reduceList . toList
41+
42+reduceList' :: (Reducible a) => [a] -> [a] -> [a]
43+reduceList' acc [] = acc
44+reduceList' [] (x:xs) = reduceList' [x] xs
45+reduceList' as (x:xs) = reduceList' (init as ++ (last as <++> x) ) xs
46+
47+reduceList :: (Reducible a) => [a] -> [a]
48+reduceList = reduceList' []
49+
50+combineReducibles :: (Reducible a, Eq a) => a -> a -> [a]
51+combineReducibles r s =
52+ let (conts, rs) = topLevelContainers r
53+ (conts', ss) = topLevelContainers s
54+ shared = conts `intersect` conts'
55+ remaining = conts \\ shared
56+ remaining' = conts' \\ shared
57+ in
58+ case null shared of
59+ True -> case (not . null) rs && isSpace (last rs) of
60+ True -> rebuild conts (init rs) ++ [last rs, s]
61+ False -> [r,s]
62+ False -> rebuild
63+ shared $
64+ reduceList $
65+ (rebuild remaining rs) ++ (rebuild remaining' ss)
66+
67+instance Reducible Inline where
68+ s1@(Span (id1, classes1, kvs1) ils1) <++> s2@(Span (id2, classes2, kvs2) ils2) =
69+ let classes' = classes1 `intersect` classes2
70+ kvs' = kvs1 `intersect` kvs2
71+ classes1' = classes1 \\ classes'
72+ kvs1' = kvs1 \\ kvs'
73+ classes2' = classes2 \\ classes'
74+ kvs2' = kvs2 \\ kvs'
75+ in
76+ case null classes' && null kvs' of
77+ True -> [s1,s2]
78+ False -> let attr' = ("", classes', kvs')
79+ attr1' = (id1, classes1', kvs1')
80+ attr2' = (id2, classes2', kvs2')
81+ s1' = case null classes1' && null kvs1' of
82+ True -> ils1
83+ False -> [Span attr1' ils1]
84+ s2' = case null classes2' && null kvs2' of
85+ True -> ils2
86+ False -> [Span attr2' ils2]
87+ in
88+ [Span attr' $ reduceList $ s1' ++ s2']
89+
90+ (Str x) <++> (Str y) = [Str (x++y)]
91+ il <++> il' = combineReducibles il il'
92+
93+ container (Emph _) = Container Emph
94+ container (Strong _) = Container Strong
95+ container (Strikeout _) = Container Strikeout
96+ container (Subscript _) = Container Subscript
97+ container (Superscript _) = Container Superscript
98+ container (Quoted qt _) = Container $ Quoted qt
99+ container (Cite cs _) = Container $ Cite cs
100+ container (Span attr _) = Container $ Span attr
101+ container _ = NullContainer
102+
103+ innards (Emph ils) = ils
104+ innards (Strong ils) = ils
105+ innards (Strikeout ils) = ils
106+ innards (Subscript ils) = ils
107+ innards (Superscript ils) = ils
108+ innards (Quoted _ ils) = ils
109+ innards (Cite _ ils) = ils
110+ innards (Span _ ils) = ils
111+ innards _ = []
112+
113+ isSpace Space = True
114+ isSpace _ = False
115+
116+instance Reducible Block where
117+ (Div (ident, classes, kvs) blks) <++> blk | "list-item" `elem` classes =
118+ [Div (ident, classes, kvs) (reduceList blks), blk]
119+
120+ blk <++> blk' = combineReducibles blk blk'
121+
122+ container (BlockQuote _) = Container BlockQuote
123+ container (Div attr _) = Container $ Div attr
124+ container _ = NullContainer
125+
126+ innards (BlockQuote bs) = bs
127+ innards (Div _ bs) = bs
128+ innards _ = []
129+
130+ isSpace _ = False
131+
132+
133+topLevelContainers' :: (Reducible a) => [a] -> ([Container a], [a])
134+topLevelContainers' (r : []) = case container r of
135+ NullContainer -> ([], [r])
136+ _ ->
137+ let (conts, inns) = topLevelContainers' (innards r)
138+ in
139+ ((container r) : conts, inns)
140+topLevelContainers' rs = ([], rs)
141+
142+topLevelContainers :: (Reducible a) => a -> ([Container a], [a])
143+topLevelContainers il = topLevelContainers' [il]
144+
145+rebuild :: [Container a] -> [a] -> [a]
146+rebuild [] xs = xs
147+rebuild ((Container f) : cs) xs = rebuild cs $ [f xs]
148+rebuild (NullContainer : cs) xs = rebuild cs $ xs
149+
150+