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