]> Git — Sourcephile - doclang.git/blob - Language/DTC/Write/XML.hs
Add style/dtc-html5.css
[doclang.git] / Language / DTC / Write / XML.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.DTC.Write.XML where
5
6 import Control.Monad (forM_)
7 import Data.Bool
8 import Data.Foldable (Foldable(..))
9 import Data.Function (($), (.))
10 import Data.Functor ((<$>))
11 import Data.Maybe (Maybe(..))
12 import Data.Monoid (Monoid(..))
13 import Data.Semigroup (Semigroup(..))
14 import Data.Sequence (Seq)
15 import Data.TreeSeq.Strict (Tree(..))
16 import Text.Blaze ((!))
17 import Text.Blaze.Utils
18 import Text.Blaze.XML (XML)
19 import qualified Data.Char as Char
20 import qualified Data.Function as Fun
21 import qualified Data.Map.Strict as Map
22 import qualified Data.Text as Text
23 import qualified Data.Text.Lazy as TL
24 import qualified Text.Blaze as B
25 import qualified Text.Blaze.DTC as XML
26 import qualified Text.Blaze.DTC.Attributes as XA
27 import qualified Text.Blaze.Internal as B
28
29 import Data.Locale
30 import Language.DTC.Anchor (plainifyWords)
31 import Language.DTC.Document as DTC hiding (XML)
32
33 document :: Locales ls => LocaleIn ls -> Document -> XML
34 document loc 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 xmlify head
42 xmlify body
43
44 -- * Class 'Xmlify'
45 class Xmlify a where
46 xmlify :: a -> XML
47
48 instance Xmlify TL.Text where
49 xmlify = B.toMarkup
50 instance Xmlify Head where
51 xmlify Head{..} =
52 XML.about $ xmlify about
53 instance Xmlify (Tree BodyNode) where
54 xmlify (Tree n ts) =
55 case n of
56 BodyBlock b -> xmlify b
57 BodySection{..} ->
58 xmlCommonAttrs attrs $
59 XML.section $ do
60 xmlify title
61 forM_ aliases xmlify
62 xmlify ts
63 instance Xmlify Block where
64 xmlify = \case
65 BlockPara para -> xmlify para
66 BlockToC{..} ->
67 xmlCommonAttrs attrs $
68 XML.toc
69 !?? mayAttr XA.depth depth
70 BlockToF{..} ->
71 xmlCommonAttrs attrs $
72 XML.tof $
73 XML.ul $
74 forM_ types $
75 XML.li . xmlify
76 BlockIndex{..} ->
77 xmlCommonAttrs attrs $
78 XML.index $ do
79 XML.ul $
80 forM_ terms $ \aliases ->
81 XML.li $
82 xmlify $
83 TL.unlines $
84 plainifyWords <$> aliases
85 BlockFigure{..} ->
86 xmlCommonAttrs attrs $
87 XML.figure
88 ! XA.type_ (attrify type_) $ do
89 xmlify mayTitle
90 xmlify paras
91 BlockReferences{..} ->
92 xmlCommonAttrs attrs $
93 XML.references $ xmlify refs
94 instance Xmlify Para where
95 xmlify = \case
96 ParaItem{..} -> xmlify item
97 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
98 instance Xmlify ParaItem where
99 xmlify = \case
100 ParaPlain p -> XML.p $ xmlify p
101 ParaComment c ->
102 XML.comment $ TL.toStrict c
103 ParaArtwork{..} ->
104 XML.artwork
105 ! XA.type_ (attrify type_) $ do
106 xmlify text
107 ParaQuote{..} ->
108 XML.quote
109 ! XA.type_ (attrify type_) $ do
110 xmlify paras
111 ParaOL items -> XML.ol $ forM_ items xmlify
112 ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
113 instance Xmlify ListItem where
114 xmlify ListItem{..} =
115 XML.li ! XA.name (attrify name) $ xmlify paras
116 instance Xmlify (Tree PlainNode) where
117 xmlify (Tree n ts) =
118 case n of
119 PlainText t -> xmlify t
120 PlainBR -> XML.br
121 PlainGroup -> xmlify ts
122 PlainB -> XML.b $ xmlify ts
123 PlainCode -> XML.code $ xmlify ts
124 PlainDel -> XML.del $ xmlify ts
125 PlainI -> XML.i $ xmlify ts
126 PlainNote{..} -> XML.note $ xmlify note
127 PlainQ -> XML.q $ xmlify ts
128 PlainSC -> XML.sc $ xmlify ts
129 PlainSub -> XML.sub $ xmlify ts
130 PlainSup -> XML.sup $ xmlify ts
131 PlainU -> XML.u $ xmlify ts
132 PlainEref to -> XML.eref ! XA.to (attrify to) $ xmlify ts
133 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
134 PlainRef to -> XML.ref ! XA.to (attrify to) $ xmlify ts
135 PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
136
137 instance Xmlify About where
138 xmlify About{..} = do
139 xmlify titles
140 xmlify authors
141 xmlify editor
142 xmlify date
143 forM_ version $ XML.version . xmlify
144 forM_ keywords $ XML.keyword . xmlify
145 xmlify links
146 xmlify includes
147 instance Xmlify Include where
148 xmlify Include{..} =
149 XML.include True
150 ! XA.href (attrify href)
151 instance Xmlify Date where
152 xmlify Date{..} =
153 XML.date
154 ! XA.year (attrify year)
155 !?? mayAttr XA.month month
156 !?? mayAttr XA.day day
157 instance Xmlify Link where
158 xmlify Link{..} =
159 XML.link
160 !?? mayAttr XA.name name
161 !?? mayAttr XA.rel rel
162 !?? mayAttr XA.href href
163 $ xmlify plain
164 instance Xmlify Entity where
165 xmlify Entity{..} =
166 XML.entity
167 !?? mayAttr XA.name name
168 !?? mayAttr XA.street street
169 !?? mayAttr XA.zipcode zipcode
170 !?? mayAttr XA.city city
171 !?? mayAttr XA.region region
172 !?? mayAttr XA.country country
173 !?? mayAttr XA.email email
174 !?? mayAttr XA.tel tel
175 !?? mayAttr XA.fax fax
176 instance Xmlify Title where
177 xmlify (Title t) = XML.title $ xmlify t
178 instance Xmlify Alias where
179 xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
180 instance Xmlify Reference where
181 xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
182
183 instance Xmlify a => Xmlify (Maybe a) where
184 xmlify = foldMap xmlify
185 instance Xmlify a => Xmlify [a] where
186 xmlify = foldMap xmlify
187 instance Xmlify a => Xmlify (Seq a) where
188 xmlify = foldMap xmlify
189
190 xmlId :: Ident -> B.Attribute
191 xmlId (Ident i) = XA.id $ attrify i
192
193 xmlCommonAttrs :: CommonAttrs -> XML -> XML
194 xmlCommonAttrs CommonAttrs{id=ident, ..} =
195 (case ident of
196 Nothing -> Fun.id
197 Just (Ident i) ->
198 B.AddCustomAttribute "id" $
199 B.String $ TL.unpack i) .
200 case classes of
201 [] -> Fun.id
202 _ ->
203 B.AddCustomAttribute "class" $
204 B.String $ TL.unpack $ TL.unwords classes