]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/Text.hs
Add DTC.Index.
[doclang.git] / Language / TCT / Write / Text.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 -- | Render a TCT file in plain Text.
5 module Language.TCT.Write.Text where
6
7 import Control.Monad (Monad(..), mapM)
8 import Data.Bool
9 import Data.Eq (Eq(..))
10 import Data.Foldable (Foldable(..))
11 import Data.Function (($), (.))
12 import Data.Functor ((<$>))
13 import Data.Int (Int,Int64)
14 import Data.Monoid (Monoid(..))
15 import Data.Ord (Ord(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.Sequence (ViewL(..), ViewR(..))
18 import Data.Text (Text)
19 import Data.TreeSeq.Strict (Tree(..),Trees)
20 import Prelude (Num(..), undefined, Integral(..))
21 import Text.Show (Show(..))
22 import qualified Control.Monad.Trans.State as S
23 import qualified Data.List as L
24 import qualified Data.Sequence as Seq
25 import qualified Data.Text as Text
26 import qualified Data.Text.Lazy as TL
27
28 import Language.TCT.Tree
29 import Language.TCT.Cell
30 import Language.TCT.Token
31 import Language.TCT.Elem
32
33 tl :: Text -> TL.Text
34 tl = TL.fromStrict
35
36 -- * Type 'Config_Text'
37 data Config_Text
38 = Config_Text
39 { config_text_escape :: Bool
40 } deriving (Eq, Show)
41
42 config_text :: Config_Text
43 config_text =
44 Config_Text
45 { config_text_escape = True
46 }
47
48 text :: Config_Text -> Trees (Cell Key) Tokens -> TL.Text
49 text cfg = textTreesCell cfg . treePosLastCell
50
51 treeRackUpLeft :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
52 treeRackUpLeft t = go t
53 where
54 Pos l0 c0 = posTree t
55 rackUpLeft pos =
56 Pos
57 (linePos pos - l0 + 1)
58 (columnPos pos - c0 + 1)
59 go :: Tree (Cell k) (Cell a) -> Tree (Cell k) (Cell a)
60 go (Tree0 (Cell pos posEnd c)) =
61 Tree0 $ Cell (rackUpLeft pos) (rackUpLeft posEnd) c
62 go (TreeN (Cell pos posEnd c) ts) =
63 TreeN
64 (Cell (rackUpLeft pos) (rackUpLeft posEnd) c)
65 (go <$> ts)
66
67 treePosLastCell ::
68 Trees (Cell k) Tokens ->
69 Trees (Pos,Cell k) (Pos,Tokens)
70 treePosLastCell t = S.evalState (go`mapM`t) (Pos 1 1)
71 where
72 go :: Tree (Cell k) Tokens ->
73 S.State Pos (Tree (Pos,Cell k) (Pos,Tokens))
74 go (Tree0 ts) = do
75 lastPos <- S.get
76 case Seq.viewr ts of
77 EmptyR ->
78 return $ Tree0 (lastPos,ts)
79 _ :> cell -> do
80 S.put $ posEndCell cell
81 return $ Tree0 (lastPos,ts)
82 go (TreeN cell ts) = do
83 lastPos <- S.get
84 S.put $ posEndCell cell
85 ts' <- go`mapM`ts
86 return $ TreeN (lastPos,cell) ts'
87
88 int64 :: Integral i => i -> Int64
89 int64 = fromInteger . toInteger
90
91 textTreeCell ::
92 Config_Text ->
93 Tree (Pos,Cell Key) (Pos,Tokens) ->
94 TL.Text
95 textTreeCell cfg (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) =
96 textIndentCell (posEnd,pos) <>
97 TL.replicate (int64 lvl) "#" <> " " <>
98 (case Seq.viewl ts of
99 Tree0 (_,title) :< _ ->
100 textIndentToken cfg title
101 _ -> "") <>
102 textTreesCell cfg
103 (case Seq.viewl ts of
104 Tree0{} :< ts' -> ts'
105 _ -> ts)
106 textTreeCell cfg (Tree0 (posEnd,toks)) =
107 case Seq.viewl toks of
108 EmptyL -> textIndentToken cfg toks
109 t0:<_ -> textIndentCell (posEnd,posCell t0) <> textIndentToken cfg toks
110 textTreeCell cfg (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
111 textIndentCell (posEnd,pos) <>
112 textCellKey cfg cell cs
113
114 textIndentCell :: (Pos,Pos) -> TL.Text
115 textIndentCell (Pos lineLast colLast,Pos line col)
116 | lineLast < line =
117 TL.replicate (int64 $ line - (lineLast+1)) "\n" <>
118 TL.replicate (int64 $ col - 1) " "
119 | lineLast == line && colLast <= col =
120 TL.replicate (int64 $ col - colLast) " "
121 | otherwise = undefined
122
123 textCellKey ::
124 Config_Text ->
125 Cell Key ->
126 Trees (Pos,Cell Key) (Pos,Tokens) ->
127 TL.Text
128 textCellKey cfg (Cell _pos _posEnd key) cells = do
129 case key of
130 KeyColon n wh -> textKey n wh ":"
131 KeyGreat n wh -> textKey n wh ">"
132 KeyEqual n wh -> textKey n wh "="
133 KeyBar n wh -> textKey n wh "|"
134 KeyDash -> textKey "" "" "- "
135 KeyDashDash -> textKey "" "" "-- "
136 KeyLower name attrs ->
137 "<" <> tl name <> textAttrs attrs <>
138 textTreesCell cfg cells
139 KeySection{} -> undefined
140 KeyDotSlash p ->
141 "./" <> TL.pack p <>
142 textTreesCell cfg cells
143 where
144 textKey :: Text -> White -> TL.Text -> TL.Text
145 textKey name wh mark =
146 tl name <> tl wh <> mark <>
147 textTreesCell cfg cells
148
149 textTreesCell ::
150 Config_Text ->
151 Trees (Pos,Cell Key) (Pos,Tokens) ->
152 TL.Text
153 textTreesCell cfg = foldMap (textTreeCell cfg)
154
155 textIndentToken :: Config_Text -> Tokens -> TL.Text
156 textIndentToken _cfg (Seq.viewl -> EmptyL) = ""
157 textIndentToken cfg toks@(Seq.viewl -> Cell pos _ _ :< _) =
158 goTokens toks `S.evalState` linePos pos
159 where
160 indent = TL.replicate (int64 $ columnPos pos - 1) " "
161 go :: Cell Token -> S.State Int TL.Text
162 go tok =
163 case unCell tok of
164 TokenPlain txt -> do
165 lnum <- S.get
166 let lines = Text.splitOn "\n" txt
167 S.put (lnum - 1 + L.length lines)
168 return $
169 case lines of
170 [] -> undefined
171 (l0:ls) -> tl l0 <> mconcat ((\l -> "\n"<>indent<>tl l)<$>ls)
172 TokenTag v -> return $ "#"<>tl v
173 TokenEscape c ->
174 return $
175 if config_text_escape cfg
176 then tl $ Text.pack ['\\',c]
177 else TL.singleton c
178 TokenLink lnk -> return $ tl lnk
179 TokenPair grp ts -> do
180 ts' <- goTokens ts
181 return $ tl o<>ts'<>tl c
182 where (o,c) = pairBorders grp ts
183 goTokens :: Tokens -> S.State Int TL.Text
184 goTokens ts = do
185 ts' <- go`mapM`ts
186 return $ foldr (<>) mempty ts'
187
188 textAttrs :: Attrs -> TL.Text
189 textAttrs = foldMap textAttr
190
191 textAttr :: (Text,Attr) -> TL.Text
192 textAttr (attr_white,Attr{..}) =
193 mconcat $ tl <$>
194 [ attr_white
195 , attr_name
196 , attr_open
197 , attr_value
198 , attr_close
199 ]
200
201 textToken :: Token -> TL.Text
202 textToken (TokenPlain txt) = tl txt
203 textToken (TokenTag v) = "#"<>tl v
204 textToken (TokenEscape c) = TL.singleton c -- tl $ Text.pack ['\\',c]
205 textToken (TokenLink lnk) = tl lnk
206 textToken (TokenPair grp t) = tl o<>textTokens t<>tl c
207 where (o,c) = pairBorders grp t
208
209 textTokens :: Tokens -> TL.Text
210 textTokens ts = foldMap (textToken . unCell) ts