]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/XML.hs
Automatize localesOf.
[doclang.git] / Language / DTC / Write / XML.hs
1 {-# LANGUAGE RecordWildCards #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.DTC.Write.XML where
5
6 -- import Data.Foldable (Foldable(..))
7 import Control.Monad (forM_, mapM_)
8 import Data.Bool
9 import Data.Function (($), (.))
10 import Data.Maybe (Maybe(..))
11 import Data.Monoid (Monoid(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.Text (Text)
14 import Text.Blaze ((!))
15 import Text.Blaze.Utils
16 import Text.Blaze.XML (XML)
17 import Data.TreeSeq.Strict (Tree(..))
18 import qualified Data.Char as Char
19 import qualified Data.Map.Strict as Map
20 import qualified Data.Text as Text
21 import qualified Text.Blaze as B
22 import qualified Text.Blaze.DTC as XML
23 import qualified Text.Blaze.DTC.Attributes as XA
24 import qualified Text.Blaze.Internal as B
25
26 import Data.Locale
27 import Language.DTC.Document (MayText(..), whenMayText)
28 import qualified Language.DTC.Document as DTC
29
30 xmlText :: Text -> XML
31 xmlText = B.toMarkup
32
33 xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
34 xmlDocument loc DTC.Document{..} = do
35 let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
36 XML.xmlModel "./schema/dtc.rnc"
37 XML.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
38 XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
39 XML.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl"
40 XML.document $ do
41 xmlHead head
42 xmlBody body
43
44 xmlHead :: DTC.Head -> XML
45 xmlHead DTC.Head{..} =
46 XML.about $ xmlAbout about
47
48 xmlBody :: DTC.Body -> XML
49 xmlBody = mapM_ $ \case
50 TreeN k ts -> xmlBodyKey k $ xmlBody ts
51 Tree0 vs -> xmlBodyValue `mapM_` vs
52
53 xmlBodyKey :: DTC.BodyKey -> XML -> XML
54 xmlBodyKey k body = case k of
55 DTC.Section{..} ->
56 xmlCommonAttrs attrs $
57 XML.section $ do
58 xmlTitle title
59 forM_ aliases xmlAlias
60 body
61
62 xmlBodyValue :: DTC.BodyValue -> XML
63 xmlBodyValue = \case
64 DTC.ToC{..} ->
65 xmlCommonAttrs attrs $
66 XML.toc
67 !?? mayAttr XA.depth depth
68 DTC.ToF{..} ->
69 xmlCommonAttrs attrs $
70 XML.tof
71 !?? mayAttr XA.depth depth
72 DTC.Figure{..} ->
73 xmlCommonAttrs attrs $
74 XML.figure
75 ! XA.type_ (attrValue type_) $ do
76 xmlTitle title
77 xmlVerticals verts
78 DTC.Vertical v -> xmlVertical v
79
80 xmlAbout :: DTC.About -> XML
81 xmlAbout DTC.About{..} = do
82 forM_ titles $ xmlTitle
83 forM_ authors $ xmlAuthor
84 forM_ editor $ xmlEditor
85 forM_ date $ xmlDate
86 whenMayText version xmlVersion
87 forM_ keywords $ xmlKeyword
88 forM_ links $ xmlLink
89 forM_ includes $ xmlInclude
90
91 xmlInclude :: DTC.Include -> XML
92 xmlInclude DTC.Include{..} =
93 XML.include True
94 ! XA.href (attrValue href)
95
96 xmlKeyword :: Text -> XML
97 xmlKeyword = XML.keyword . xmlText
98
99 xmlVersion :: MayText -> XML
100 xmlVersion (MayText t) = XML.version $ xmlText t
101
102 xmlDate :: DTC.Date -> XML
103 xmlDate DTC.Date{..} =
104 XML.date
105 ! XA.year (attrValue year)
106 !?? mayAttr XA.month month
107 !?? mayAttr XA.day day
108
109 xmlLink :: DTC.Link -> XML
110 xmlLink DTC.Link{..} =
111 XML.link
112 !?? mayAttr XA.name name
113 !?? mayAttr XA.rel rel
114 !?? mayAttr XA.href href
115 $ xmlHorizontals body
116
117 xmlAddress :: DTC.Address -> XML
118 xmlAddress DTC.Address{..} =
119 XML.address
120 !?? mayAttr XA.street street
121 !?? mayAttr XA.zipcode zipcode
122 !?? mayAttr XA.city city
123 !?? mayAttr XA.region region
124 !?? mayAttr XA.country country
125 !?? mayAttr XA.email email
126 !?? mayAttr XA.tel tel
127 !?? mayAttr XA.fax fax
128
129 xmlAuthor :: DTC.Entity -> XML
130 xmlAuthor DTC.Entity{..} =
131 XML.author
132 !?? mayAttr XA.name name
133 $ xmlAddress address
134
135 xmlEditor :: DTC.Entity -> XML
136 xmlEditor DTC.Entity{..} =
137 XML.editor
138 !?? mayAttr XA.name name
139 $ xmlAddress address
140
141 xmlTitle :: DTC.Title -> XML
142 xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
143
144 xmlAlias :: DTC.Alias -> XML
145 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
146
147 xmlId :: DTC.Ident -> B.Attribute
148 xmlId (DTC.Ident i) = XA.id $ attrValue i
149
150 xmlVerticals :: DTC.Verticals -> XML
151 xmlVerticals = (`forM_` xmlVertical)
152
153 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
154 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
155 (case ident of
156 Nothing -> \m -> m
157 Just (DTC.Ident i) -> B.AddCustomAttribute "id" (B.Text i)) .
158 case classes of
159 [] -> \m -> m
160 _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
161
162 xmlVertical :: DTC.Vertical -> XML
163 xmlVertical = \case
164 DTC.Para{..} ->
165 xmlCommonAttrs attrs $
166 XML.para $ xmlHorizontals horis
167 DTC.OL{..} ->
168 xmlCommonAttrs attrs $
169 XML.ol $ forM_ items $ XML.li . xmlVerticals
170 DTC.UL{..} ->
171 xmlCommonAttrs attrs $
172 XML.ul $ forM_ items $ XML.li . xmlVerticals
173 DTC.RL{..} ->
174 xmlCommonAttrs attrs $
175 XML.rl $ forM_ refs $ xmlReference
176 -- DTC.Index -> XML.index
177 DTC.Comment c ->
178 XML.comment c
179 DTC.Artwork{..} ->
180 xmlCommonAttrs attrs $
181 XML.artwork mempty
182
183 xmlHorizontals :: DTC.Horizontals -> XML
184 xmlHorizontals = (`forM_` xmlHorizontal)
185
186 xmlHorizontal :: DTC.Horizontal -> XML
187 xmlHorizontal = \case
188 DTC.Plain txt -> B.toMarkup txt
189 DTC.BR -> XML.br
190 DTC.B hs -> XML.b $ xmlHorizontals hs
191 DTC.Code hs -> XML.code $ xmlHorizontals hs
192 DTC.Del hs -> XML.del $ xmlHorizontals hs
193 DTC.I hs -> XML.i $ xmlHorizontals hs
194 DTC.Note hs -> XML.note $ xmlHorizontals hs
195 DTC.Q hs -> XML.q $ xmlHorizontals hs
196 DTC.SC hs -> XML.sc $ xmlHorizontals hs
197 DTC.Sub hs -> XML.sub $ xmlHorizontals hs
198 DTC.Sup hs -> XML.sup $ xmlHorizontals hs
199 DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
200 DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
201 DTC.Ref to hs -> XML.ref ! XA.to (attrValue to) $ xmlHorizontals hs
202 DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
203
204 xmlReference :: DTC.Reference -> XML
205 xmlReference DTC.Reference{..} =
206 XML.reference mempty