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