]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Write/Plain.hs
Fix TCT dependencies dump.
[doclang.git] / Hdoc / TCT / Write / Plain.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Hdoc.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 Hdoc.TCT
32 import Hdoc.TCT.Utils
33 -- import Hdoc.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
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 TokenAt b r -> (if b then plainify '^' else mempty) <> plainify '@' <> plainify r
215 TokenTag b r -> (if b then plainify '^' else mempty) <> plainify '#' <> plainify r
216 TokenLink l -> plainify l
217 TokenEscape c -> do
218 esc <- S.gets state_escape
219 if esc
220 then plainify ['\\', c]
221 else plainify c
222 instance Plainify ElemAttrs where
223 plainify = foldMap plainify
224 instance Plainify (White,ElemAttr) where
225 plainify (elemAttr_white,ElemAttr{..}) =
226 mconcat $ plainify <$>
227 [ elemAttr_white
228 , elemAttr_name
229 , elemAttr_open
230 , elemAttr_value
231 , elemAttr_close
232 ]
233
234 {-
235 -- * Class 'RackUpLeft'
236 class RackUpLeft a where
237 rackUpLeft :: a -> S.State (Maybe Pos) a
238 instance RackUpLeft Pos where
239 rackUpLeft pos@Pos{..} = do
240 S.get >>= \case
241 Nothing -> return pos
242 Just (Pos l0 c0) ->
243 return Pos
244 { pos_line = pos_line - l0 + 1
245 , pos_column = pos_column - c0 + 1
246 }
247 instance RackUpLeft (Cell a) where
248 rackUpLeft (Cell bp ep a) = do
249 S.modify' $ \case
250 Nothing -> Just bp
251 p -> p
252 Cell
253 <$> rackUpLeft bp
254 <*> rackUpLeft ep
255 <*> pure a
256 instance RackUpLeft a => RackUpLeft (Seq a) where
257 rackUpLeft = mapM rackUpLeft
258 instance RackUpLeft a => RackUpLeft (Tree a) where
259 rackUpLeft (Tree n ts) =
260 Tree
261 <$> rackUpLeft n
262 <*> rackUpLeft ts
263 -}