]> Git — Sourcephile - doclang.git/blob - Language/TCT/Write/DTC.hs
Add DTC writing: <ul>.
[doclang.git] / Language / TCT / Write / DTC.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ViewPatterns #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 -- | Render a TCT file in DTC.
6 module Language.TCT.Write.DTC where
7
8 import Control.Monad (Monad(..), forM_, when)
9 import Data.Bool
10 import Data.Foldable (Foldable(..))
11 import Data.Function (($), (.), flip)
12 import Data.Functor ((<$>))
13 import Data.Monoid (Monoid(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.Sequence (ViewL(..))
16 import Data.String (String)
17 import Data.Text (Text)
18 import Text.Blaze ((!))
19 import Text.Show (Show(..))
20 import Data.Map.Strict (Map)
21 import qualified Data.Sequence as Seq
22 import qualified Data.Text as Text
23 import qualified Text.Blaze as B
24 import qualified Text.Blaze.Internal as B
25 import qualified Data.Text.Lazy as TL
26 import qualified Data.Map.Strict as Map
27
28 import Language.TCT.Tree
29 import Language.TCT.Token
30 import Language.TCT.Elem hiding (trac,dbg)
31 import qualified Language.TCT.Write.Text as Write
32 import Text.Blaze.Utils
33 import Text.Blaze.DTC (DTC)
34 import qualified Text.Blaze.DTC as D
35 import qualified Text.Blaze.DTC.Attributes as DA
36
37 import Debug.Trace (trace)
38 trac :: String -> a -> a
39 -- trac _m x = x
40 trac m x = trace m x
41 dbg :: Show a => String -> a -> a
42 dbg m x = trac (m <> ": " <> show x) x
43
44 dtc :: Trees (Cell Key) (Cell Tokens) -> DTC
45 dtc ts = do
46 let lang = "fr"
47 D.xmlModel "./schema/dtc.rnc"
48 D.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
49 D.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
50 D.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl"
51 D.document $
52 case Seq.viewl ts of
53 TreeN (unCell -> KeySection{})
54 (Seq.viewl -> Tree0 (unCell -> Write.t_Tokens -> TL.toStrict -> title) :< head)
55 :< body -> do
56 d_Trees [] (mangleHead title head)
57 d_Trees [] body
58 _ ->
59 d_Trees [] ts
60 where
61 mangleHead ::
62 Text ->
63 Trees (Cell Key) (Cell Tokens) ->
64 Trees (Cell Key) (Cell Tokens)
65 mangleHead title head =
66 (<$> head) $ \case
67 TreeN cell@(unCell -> KeyColon "about" _) about ->
68 TreeN cell $ Seq.fromList (name <$> Text.splitOn "\n" title) <> about
69 where
70 name =
71 TreeN (cell0 (KeyColon "name" "")) .
72 Seq.fromList . return .
73 Tree0 . cell0 .
74 tokens . return . TokenPlain
75 t -> t
76
77 d_Trees :: [Key] -> Trees (Cell Key) (Cell Tokens) -> DTC
78 d_Trees path ts =
79 case () of
80 _ | (ul,ts') <- Seq.spanl (\case TreeN (unCell -> KeyDash) _ -> True
81 Tree0 (unCell -> unTokens -> toList -> [TokenPair (PairElem "li" _) _]) -> True
82 _ -> False) ts
83 , not (null ul) -> do
84 D.ul $ forM_ ul $ d_Tree path
85 d_Trees path ts'
86 _ | t:<ts' <- Seq.viewl ts -> do
87 d_Tree path t
88 d_Trees path ts'
89 _ ->
90 return ()
91
92 d_Tree :: [Key] -> Tree (Cell Key) (Cell Tokens) -> DTC
93 d_Tree path (TreeN (unCell -> key@KeySection{}) ts) =
94 case Seq.viewl children of
95 Tree0 (Cell _posTitle _ (unTokens -> toList -> [TokenPlain title])) :< body ->
96 d_attrs (mangleAttrs title attrs) $
97 case Text.splitOn "\n" title of
98 t0:t1 ->
99 D.section ! DA.name (attrValue t0) $ do
100 let st = Text.intercalate "\n" t1
101 when (not (Text.null st)) $
102 D.name $ B.toMarkup st
103 d_content body
104 [] ->
105 D.section ! DA.name (attrValue title) $
106 d_content body
107 Tree0 (Cell _posTitle _ title) :< body ->
108 d_attrs (mangleAttrs (TL.toStrict $ Write.t_Tokens title) attrs) $
109 D.section $ do
110 D.name $ d_Tokens (key:path) title
111 d_content body
112 _ ->
113 d_attrs attrs $
114 D.section $ d_content children
115 where
116 (attrs,children) = partitionAttributesChildren ts
117 d_content cs = d_Trees (key:path) cs
118 mangleAttrs :: Text -> Attributes -> Attributes
119 mangleAttrs title = Map.insertWith (\_new old -> old) "id" title
120 d_Tree path (Tree0 cell) = d_CellTokens path cell
121 d_Tree path (TreeN cell@(unCell -> KeyColon{}) ts) =
122 let (attrs,children) = partitionAttributesChildren ts in
123 d_attrs attrs $ d_CellKey path cell children
124 d_Tree path (TreeN cell ts) = d_CellKey path cell ts
125
126 d_CellKey :: [Key] -> Cell Key -> Trees (Cell Key) (Cell Tokens) -> DTC
127 d_CellKey path (Cell _pos _posEnd key) cells = do
128 case key of
129 KeyColon n _wh -> d_Key n
130 KeyGreat n _wh -> d_Key n
131 KeyEqual n _wh -> d_Key n
132 KeyBar n _wh -> d_Key n
133 KeyDash -> D.li $ d_Trees (key:path) cells
134 {-
135 KeyLower name attrs -> do
136 B.Content $ "<"<>B.toMarkup name
137 d_Attrs attrs
138 forM_ cells $ d_Tree path
139 -}
140 where
141 d_Key :: Text -> DTC
142 d_Key name | null cells =
143 B.CustomLeaf (B.Text name) True mempty
144 d_Key name =
145 B.CustomParent (B.Text name) $
146 d_Trees (key:path) cells
147
148 d_CellTokens :: [Key] -> Cell Tokens -> DTC
149 d_CellTokens path (Cell _pos _posEnd ts) =
150 -- case L.find (\case KeySection{} -> True; _ -> False) $ dbg "d_CellTokens: path:" path of
151 case dbg "d_CellTokens: path" path of
152 KeySection{}:_ ->
153 case ts of
154 (unTokens -> toList -> [TokenPair PairElem{} _ts]) -> d_Tokens path ts
155 _ -> D.para $ d_Tokens path ts
156 _ -> d_Tokens path ts
157
158 d_Tokens :: [Key] -> Tokens -> DTC
159 d_Tokens _path tok = goTokens tok
160 where
161 -- indent = Text.replicate (columnPos pos - 1) " "
162 go :: Token -> DTC
163 go (TokenPlain t) = B.toMarkup t
164 go (TokenTag t) = D.ref mempty ! DA.to (attrValue t)
165 go (TokenEscape c) = B.toMarkup c
166 go (TokenLink lnk) = D.eref (B.toMarkup lnk) ! DA.to (attrValue lnk)
167 go (TokenPair PairSlash ts) = D.i $ goTokens ts
168 go (TokenPair PairBackquote ts) = D.code $ goTokens ts
169 go (TokenPair PairFrenchquote ts) = D.q $ goTokens ts
170 go (TokenPair PairHash (unTokens -> toList -> [TokenPlain ts])) =
171 D.ref mempty ! DA.to (attrValue ts)
172 go (TokenPair (PairElem name attrs) ts) =
173 d_Attrs attrs $
174 case ts of
175 Tokens s | Seq.null s ->
176 B.CustomLeaf (B.Text name) True mempty
177 _ -> B.CustomParent (B.Text name) $ goTokens ts
178 go (TokenPair p ts) = do
179 let (o,c) = pairBorders p ts
180 B.toMarkup o
181 goTokens ts
182 B.toMarkup c
183 goTokens :: Tokens -> DTC
184 goTokens (Tokens ts) = foldMap go ts
185
186 d_Attrs :: Attrs -> DTC -> DTC
187 d_Attrs = flip $ foldl' d_Attr
188
189 d_Attr :: DTC -> (Text,Attr) -> DTC
190 d_Attr acc (_,Attr{..}) =
191 B.AddCustomAttribute
192 (B.Text attr_name)
193 (B.Text attr_value)
194 acc
195
196 -- attr_id :: Text -> [(Text,Text)] -> [(Text,Text)]
197 -- attr_id title = ("id",title)
198
199 -- * Type 'Attributes'
200 type Attributes = Map Name Text
201
202 d_attrs :: Attributes -> DTC -> DTC
203 d_attrs = flip $ Map.foldrWithKey $ \n v ->
204 B.AddCustomAttribute (B.Text n) (B.Text v)
205
206 partitionAttributesChildren ::
207 Trees (Cell Key) (Cell Tokens) ->
208 (Attributes, Trees (Cell Key) (Cell Tokens))
209 partitionAttributesChildren ts = (attrs,children)
210 where
211 attrs :: Attributes
212 attrs =
213 foldr (\t acc ->
214 case t of
215 Tree0{} -> acc
216 TreeN (unCell -> KeyEqual n _wh) a -> Map.insert n v acc
217 where
218 v = TL.toStrict $
219 Write.text Write.config_text{Write.config_text_escape = False} $
220 Write.treeRackUpLeft <$> a
221 TreeN{} -> acc
222 ) mempty ts
223 children = Seq.filter (\t ->
224 case t of
225 Tree0{} -> True
226 TreeN (unCell -> KeyEqual{}) _cs -> False
227 TreeN{} -> True
228 ) ts