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