1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Hdoc.TCT.Write.Plain where
6 import Control.Applicative (liftA2)
7 import Control.Monad (Monad(..))
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 ((<$>))
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
33 -- import Hdoc.TCT.Debug
35 writePlain :: Roots -> TL.Text
36 writePlain doc = text (setStart doc def) doc
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
45 instance Semigroup Plain where
47 instance Monoid Plain where
51 runPlain :: Plain -> State -> TL.Text
52 runPlain p s = TLB.toLazyText $ S.evalState p s
54 text :: Plainify a => State -> a -> TL.Text
55 text s a = runPlain (plainify a) s
60 { state_escape :: Bool
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
72 instance Default State where
80 -- | Set the starting 'Pos' of given 'State'
81 -- by using the first 'cell_begin'.
82 setStart :: Roots -> State -> State
85 , state_unindent = pos_column pos
90 Tree (Cell (Span{span_begin}:|_) _) _ :< _ -> span_begin
93 class Plainify a where
94 plainify :: a -> Plain
95 instance Plainify () where
97 instance Plainify Char where
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)}
103 return $ TLB.singleton '\n' <> TLB.fromLazyText state_indent
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
114 let (h,ts) = TL.span (/='\n') t in
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
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.
126 instance Plainify Pos where
127 plainify new@(Pos lineNew colNew) = do
129 { state_pos=old@(Pos lineOld colOld)
133 S.modify' $ \s -> s{state_pos=new}
134 return $ TLB.fromLazyText $
135 case lineNew`compare`lineOld of
136 GT -> lines <> state_indent <> hspaces
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) =
151 ----------------------
152 NodeLower n as -> "<" <> plainify n <> plainify as <> plainify ts
153 ----------------------
156 HeaderGreat{} -> plainHeaderRepeated
157 HeaderBar{} -> plainHeaderRepeated
158 HeaderDotSlash{} -> plainify hdr
159 _ -> plainify hdr <> plainify ts
161 plainHeaderRepeated = do
164 S.modify' $ \s -> s{state_indent =
166 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " " <>
170 S.modify' $ \s -> s{state_indent}
172 ----------------------
175 S.modify' $ \s -> s{state_indent =
177 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
180 S.modify' $ \s -> s{state_indent}
182 ----------------------
185 S.modify' $ \s -> s{state_indent =
187 TL.replicate (int64 (pos_column bp - state_unindent) - TL.length state_indent) " "
190 S.modify' $ \s -> s{state_indent}
192 ----------------------
193 NodeToken t -> plainify t <> plainify ts
194 ----------------------
196 plainify o <> plainify ts <> plainify c
197 where (o,c) = pairBorders p ts
198 instance Plainify Header where
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 <> "]"
208 HeaderDashDash -> "-- "
209 HeaderSection lvl -> plainify (List.replicate lvl '#')
210 HeaderDotSlash n -> plainify n
211 instance Plainify Token where
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
218 esc <- S.gets state_escape
220 then 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 <$>
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
241 Nothing -> return pos
244 { pos_line = pos_line - l0 + 1
245 , pos_column = pos_column - c0 + 1
247 instance RackUpLeft (Cell a) where
248 rackUpLeft (Cell bp ep a) = do
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) =