1 {-# LANGUAGE OverloadedStrings #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module Language.DTC.Write.XML where
5 -- import Data.Foldable (Foldable(..))
6 import Control.Monad (forM_, mapM_)
8 import Data.Function (($), (.))
9 import Data.Maybe (Maybe(..))
10 import Data.Monoid (Monoid(..))
11 import Data.Semigroup (Semigroup(..))
12 import Data.Text (Text)
13 import Text.Blaze ((!))
14 import Text.Blaze.Utils
15 import Text.Blaze.XML (XML)
16 import Data.TreeSeq.Strict (Tree(..))
17 import qualified Data.Char as Char
18 import qualified Data.Map.Strict as Map
19 import qualified Data.Text as Text
20 import qualified Text.Blaze as B
21 import qualified Text.Blaze.DTC as XML
22 import qualified Text.Blaze.DTC.Attributes as XA
23 import qualified Text.Blaze.Internal as B
26 import Language.DTC.Document (MayText(..), whenMayText)
27 import qualified Language.DTC.Document as DTC
29 xmlText :: Text -> XML
32 xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
33 xmlDocument loc DTC.Document{..} = do
34 let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
35 XML.xmlModel "./schema/dtc.rnc"
36 XML.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
37 XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
38 XML.atomStylesheet $ "./xsl/document.atom."<>lang<>".xsl"
43 xmlHead :: DTC.Head -> XML
44 xmlHead DTC.Head{..} =
45 XML.about $ xmlAbout about
47 xmlBody :: DTC.Body -> XML
48 xmlBody = mapM_ $ \case
49 TreeN k ts -> xmlBodyKey k $ xmlBody ts
50 Tree0 vs -> xmlBodyValue `mapM_` vs
52 xmlBodyKey :: DTC.BodyKey -> XML -> XML
53 xmlBodyKey k body = case k of
55 xmlCommonAttrs attrs $
58 forM_ aliases xmlAlias
61 xmlBodyValue :: DTC.BodyValue -> XML
64 xmlCommonAttrs attrs $
66 !?? mayAttr XA.depth depth
68 xmlCommonAttrs attrs $
70 !?? mayAttr XA.depth depth
72 xmlCommonAttrs attrs $
74 ! XA.type_ (attrValue type_) $ do
77 DTC.Vertical v -> xmlVertical v
79 xmlAbout :: DTC.About -> XML
80 xmlAbout DTC.About{..} = do
81 forM_ titles $ xmlTitle
82 forM_ authors $ xmlAuthor
83 forM_ editor $ xmlEditor
85 whenMayText version xmlVersion
86 forM_ keywords $ xmlKeyword
88 forM_ includes $ xmlInclude
90 xmlInclude :: DTC.Include -> XML
91 xmlInclude DTC.Include{..} =
93 ! XA.href (attrValue href)
95 xmlKeyword :: Text -> XML
96 xmlKeyword = XML.keyword . xmlText
98 xmlVersion :: MayText -> XML
99 xmlVersion (MayText t) = XML.version $ xmlText t
101 xmlDate :: DTC.Date -> XML
102 xmlDate DTC.Date{..} =
104 ! XA.year (attrValue year)
105 !?? mayAttr XA.month month
106 !?? mayAttr XA.day day
108 xmlLink :: DTC.Link -> XML
109 xmlLink DTC.Link{..} =
111 !?? mayAttr XA.name name
112 !?? mayAttr XA.rel rel
113 !?? mayAttr XA.href href
114 $ xmlHorizontals body
116 xmlAddress :: DTC.Address -> XML
117 xmlAddress DTC.Address{..} =
119 !?? mayAttr XA.street street
120 !?? mayAttr XA.zipcode zipcode
121 !?? mayAttr XA.city city
122 !?? mayAttr XA.region region
123 !?? mayAttr XA.country country
124 !?? mayAttr XA.email email
125 !?? mayAttr XA.tel tel
126 !?? mayAttr XA.fax fax
128 xmlAuthor :: DTC.Entity -> XML
129 xmlAuthor DTC.Entity{..} =
131 !?? mayAttr XA.name name
134 xmlEditor :: DTC.Entity -> XML
135 xmlEditor DTC.Entity{..} =
137 !?? mayAttr XA.name name
140 xmlTitle :: DTC.Title -> XML
141 xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
143 xmlAlias :: DTC.Alias -> XML
144 xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
146 xmlId :: DTC.Ident -> B.Attribute
147 xmlId (DTC.Ident i) = XA.id $ attrValue i
149 xmlVerticals :: DTC.Verticals -> XML
150 xmlVerticals = (`forM_` xmlVertical)
152 xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
153 xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
156 Just (DTC.Ident i) -> B.AddCustomAttribute "id" (B.Text i)) .
159 _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
161 xmlVertical :: DTC.Vertical -> XML
164 xmlCommonAttrs attrs $
165 XML.para $ xmlHorizontals horis
167 xmlCommonAttrs attrs $
168 XML.ol $ forM_ items $ XML.li . xmlVerticals
170 xmlCommonAttrs attrs $
171 XML.ul $ forM_ items $ XML.li . xmlVerticals
173 xmlCommonAttrs attrs $
174 XML.rl $ forM_ refs $ xmlReference
175 -- DTC.Index -> XML.index
179 xmlCommonAttrs attrs $
182 xmlHorizontals :: DTC.Horizontals -> XML
183 xmlHorizontals = (`forM_` xmlHorizontal)
185 xmlHorizontal :: DTC.Horizontal -> XML
186 xmlHorizontal = \case
187 DTC.Plain txt -> B.toMarkup txt
189 DTC.B hs -> XML.b $ xmlHorizontals hs
190 DTC.Code hs -> XML.code $ xmlHorizontals hs
191 DTC.Del hs -> XML.del $ xmlHorizontals hs
192 DTC.I hs -> XML.i $ xmlHorizontals hs
193 DTC.Note hs -> XML.note $ xmlHorizontals hs
194 DTC.Q hs -> XML.q $ xmlHorizontals hs
195 DTC.SC hs -> XML.sc $ xmlHorizontals hs
196 DTC.Sub hs -> XML.sub $ xmlHorizontals hs
197 DTC.Sup hs -> XML.sup $ xmlHorizontals hs
198 DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
199 DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
200 DTC.Ref to hs -> XML.ref ! XA.to (attrValue to) $ xmlHorizontals hs
201 DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
203 xmlReference :: DTC.Reference -> XML
204 xmlReference DTC.Reference{..} =