]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/Plain.hs
Fix XML merging.
[doclang.git] / Language / TCT / Write / Plain.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.TCT.Write.Plain where
5
6 import Control.Applicative (liftA2)
7 import Control.Monad (Monad(..))
8 import Data.Bool
9 import Data.Char (Char)
10 import Data.Default.Class (Default(..))
11 import Data.Eq (Eq(..))
12 import Data.Foldable (Foldable(..))
13 import Data.Function (($))
14 import Data.Functor ((<$>))
15 import Data.Int (Int)
16 import Data.List.NonEmpty (NonEmpty(..))
17 import Data.Maybe (Maybe(..))
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ord(..), Ordering(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Sequence (ViewL(..))
22 import Data.String (String, IsString(..))
23 import Prelude (Num(..), error)
24 import Text.Show (Show(..))
25 import qualified Control.Monad.Trans.State as S
26 import qualified Data.List as List
27 import qualified Data.Text.Lazy as TL
28 import qualified Data.Text.Lazy.Builder as TLB
29 import qualified Data.Sequence as Seq
30
31 import Language.TCT
32 import Language.TCT.Utils
33 -- import Language.TCT.Debug
34
35 writePlain :: Roots -> TL.Text
36 writePlain doc = text (setStart doc def) doc
37
38 -- * Type 'Plain'
39 type Plain = S.State State TLB.Builder
40 -- NOTE: To get maximum performance when building lazy Text values using a builder,
41 -- associate mappend calls to the right.
42 -- NOTE: (Semigroup.<>) associates to the right.
43 instance IsString Plain where
44 fromString = plainify
45 instance Semigroup Plain where
46 (<>) = liftA2 (<>)
47 instance Monoid Plain where
48 mempty = return ""
49 mappend = (<>)
50
51 runPlain :: Plain -> State -> TL.Text
52 runPlain p s = TLB.toLazyText $ S.evalState p s
53
54 text :: Plainify a => State -> a -> TL.Text
55 text s a = runPlain (plainify a) s
56
57 -- ** Type 'State'
58 data State
59 = State
60 { state_escape :: Bool -- FIXME: useful?
61 , state_pos :: Pos
62 -- ^ current position,
63 -- always in sync annotated 'Pos' of the input,
64 -- not with the output (whose colmuns may be shifted left by 'state_unindent')
65 , state_indent :: TL.Text
66 -- ^ indentation, which contain horizontal spaces,
67 -- but also any repeated prefix introduced by 'HeaderBar' or 'HeaderGreat'
68 , state_unindent :: Int
69 -- ^ initial 'pos_column' set by 'setStart',
70 -- useful to shift everything to the left
71 } deriving (Eq, Show)
72 instance Default State where
73 def = State
74 { state_escape = True
75 , state_pos = pos1
76 , state_indent = ""
77 , state_unindent = 1
78 }
79
80 -- | Set the starting 'Pos' of given 'State'
81 -- by using the first 'cell_begin'.
82 setStart :: Roots -> State -> State
83 setStart ts st = st
84 { state_pos = pos
85 , state_unindent = pos_column pos
86 }
87 where pos =
88 case Seq.viewl ts of
89 EmptyL -> pos1
90 Tree (Cell (Span{span_begin}:|_) _) _ :< _ -> span_begin
91
92 -- * Class 'Plainify'
93 class Plainify a where
94 plainify :: a -> Plain
95 instance Plainify () where
96 plainify = mempty
97 instance Plainify Char where
98 plainify = \case
99 '\n' -> do
100 S.modify' $ \s@State{state_pos=Pos line _col, state_indent, state_unindent} ->
101 s{state_pos=Pos (line + 1) $ state_unindent + int (TL.length state_indent)}
102 State{..} <- S.get
103 return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
104 c -> do
105 S.modify' $ \s@State{state_pos=Pos line col} ->
106 s{state_pos=Pos line (col + 1)}
107 return $ TLB.singleton c
108 instance Plainify String where
109 plainify = foldMap plainify
110 instance Plainify TL.Text where
111 plainify t
112 | TL.null t = mempty
113 | otherwise =
114 let (h,ts) = TL.span (/='\n') t in
115 case TL.uncons ts of
116 Nothing -> do
117 S.modify' $ \s@State{state_pos=Pos line col} ->
118 s{state_pos=Pos line $ col + int (TL.length h)}
119 return $ TLB.fromLazyText h
120 Just (_n,ts') ->
121 return (TLB.fromLazyText h) <>
122 -- NOTE: useless to increment the pos_column for h,
123 -- since the following '\n' will reset the pos_column.
124 plainify '\n' <>
125 plainify ts'
126 instance Plainify Pos where
127 plainify new@(Pos lineNew colNew) = do
128 State
129 { state_pos=old@(Pos lineOld colOld)
130 , state_indent
131 , state_unindent
132 } <- S.get
133 S.modify' $ \s -> s{state_pos=new}
134 return $ TLB.fromLazyText $
135 case lineNew`compare`lineOld of
136 GT -> lines <> state_indent <> hspaces
137 where
138 lines = TL.replicate (int64 $ lineNew - lineOld) "\n"
139 hspaces = TL.replicate (int64 (colNew - state_unindent) - TL.length state_indent) " "
140 EQ | colNew >= colOld ->
141 TL.replicate (int64 $ colNew - colOld) " "
142 _ -> error $ "plainify: non-ascending Pos:"
143 <> "\n old: " <> show old
144 <> "\n new: " <> show new
145 instance Plainify Roots where
146 plainify = foldMap plainify
147 instance Plainify Root where
148 plainify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) =
149 plainify bp <>
150 case nod of
151 ----------------------
152 NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
153 ----------------------
154 NodeHeader hdr ->
155 case hdr of
156 HeaderGreat{} -> plainHeaderRepeated
157 HeaderBar{} -> plainHeaderRepeated
158 HeaderDotSlash{} -> plainify hdr
159 _ -> plainify hdr <> plainify ts
160 where
161 plainHeaderRepeated = do
162 State{..} <- S.get
163 h <- plainify hdr
164 S.modify' $ \s -> s{state_indent =
165 state_indent <>
166 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
167 TLB.toLazyText h
168 }
169 r <- plainify ts
170 S.modify' $ \s -> s{state_indent}
171 return $ h <> r
172 ----------------------
173 NodeText t -> do
174 State{..} <- S.get
175 S.modify' $ \s -> s{state_indent =
176 state_indent <>
177 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
178 }
179 r <- plainify t
180 S.modify' $ \s -> s{state_indent}
181 return r
182 ----------------------
183 NodePara -> do
184 State{..} <- S.get
185 S.modify' $ \s -> s{state_indent =
186 state_indent <>
187 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
188 }
189 r <- plainify ts
190 S.modify' $ \s -> s{state_indent}
191 return r
192 ----------------------
193 NodeToken t -> plainify t <> plainify ts
194 ----------------------
195 NodePair p ->
196 plainify o <> plainify ts <> plainify c
197 where (o,c) = pairBorders p ts
198 instance Plainify Header where
199 plainify hdr =
200 case hdr of
201 HeaderColon n wh -> plainify n <> plainify wh <> ":"
202 HeaderGreat n wh -> plainify n <> plainify wh <> ">"
203 HeaderEqual n wh -> plainify n <> plainify wh <> "="
204 HeaderBar n wh -> plainify n <> plainify wh <> "|"
205 HeaderDot n -> plainify n <> "."
206 HeaderBrackets n -> "[" <> plainify n <> "]"
207 HeaderDash -> "- "
208 HeaderDashDash -> "-- "
209 HeaderSection lvl -> plainify (List.replicate lvl '#')
210 HeaderDotSlash n -> plainify n
211 instance Plainify Token where
212 plainify = \case
213 TokenText t -> plainify t
214 TokenTag t -> plainify '#' <> plainify t
215 TokenLink l -> plainify l
216 TokenEscape c -> do
217 esc <- S.gets state_escape
218 if esc
219 then plainify ['\\', c]
220 else plainify c
221 instance Plainify ElemAttrs where
222 plainify = foldMap plainify
223 instance Plainify (White,ElemAttr) where
224 plainify (elemAttr_white,ElemAttr{..}) =
225 mconcat $ plainify <$>
226 [ elemAttr_white
227 , elemAttr_name
228 , elemAttr_open
229 , elemAttr_value
230 , elemAttr_close
231 ]
232
233 {-
234 -- * Class 'RackUpLeft'
235 class RackUpLeft a where
236 rackUpLeft :: a -> S.State (Maybe Pos) a
237 instance RackUpLeft Pos where
238 rackUpLeft pos@Pos{..} = do
239 S.get >>= \case
240 Nothing -> return pos
241 Just (Pos l0 c0) ->
242 return Pos
243 { pos_line = pos_line - l0 + 1
244 , pos_column = pos_column - c0 + 1
245 }
246 instance RackUpLeft (Cell a) where
247 rackUpLeft (Cell bp ep a) = do
248 S.modify' $ \case
249 Nothing -> Just bp
250 p -> p
251 Cell
252 <$> rackUpLeft bp
253 <*> rackUpLeft ep
254 <*> pure a
255 instance RackUpLeft a => RackUpLeft (Seq a) where
256 rackUpLeft = mapM rackUpLeft
257 instance RackUpLeft a => RackUpLeft (Tree a) where
258 rackUpLeft (Tree n ts) =
259 Tree
260 <$> rackUpLeft n
261 <*> rackUpLeft ts
262 -}