]> Git — Sourcephile - doclang.git/blob - Text/Blaze/DTC.hs
Improve DTC writing.
[doclang.git] / Text / Blaze / DTC.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3 module Text.Blaze.DTC where
4
5 -- import Control.Monad (Monad(..))
6 import Data.Bool
7 import Data.Eq (Eq)
8 import Data.Function (($), (.))
9 import Data.Int (Int)
10 import Data.Maybe (Maybe(..))
11 import Data.Text (Text)
12 import Text.Blaze
13 import Text.Blaze.Internal
14 import Text.Show (Show(..))
15
16 import Text.Blaze.Utils
17 import Text.Blaze.DTC.Attributes
18
19 -- * Type 'DTC'
20 type DTC = Markup
21
22 xmlModel :: Text -> DTC
23 xmlModel rnc =
24 Leaf "xml-model" "<?xml-model" "?>\n" ()
25 ! attribute "type" " type=\"" "application/relax-ng-compact-syntax"
26 ! attribute "href" " href=\"" (attrValue rnc)
27
28 xmlStylesheet :: Text -> DTC
29 xmlStylesheet xsl =
30 Leaf "xml-stylesheet" "<?xml-stylesheet" "?>\n" ()
31 ! attribute "type" " type=\"" "text/xsl"
32 ! attribute "href" " href=\"" (attrValue xsl)
33
34 html5Stylesheet :: Text -> DTC
35 html5Stylesheet xsl =
36 Leaf "html5-stylesheet" "<?html5-stylesheet" "?>\n" ()
37 ! attribute "type" " type=\"" "text/xsl"
38 ! attribute "href" " href=\"" (attrValue xsl)
39
40 atomStylesheet :: Text -> DTC
41 atomStylesheet xsl =
42 Leaf "atom-stylesheet" "<?atom-stylesheet" "?>\n" ()
43 ! attribute "type" " type=\"" "text/xsl"
44 ! attribute "href" " href=\"" (attrValue xsl)
45
46 about :: DTC -> DTC
47 about = Parent "about" "<about" "</about>"
48 address :: DTC -> DTC
49 address = Parent "address" "<address" "</address>"
50 author :: DTC -> DTC
51 author = Parent "author" "<author" "</author>"
52 b :: DTC -> DTC
53 b = Parent "b" "<b" "</b>"
54 br :: DTC
55 br = Leaf "br" "<br" " />" ()
56 call :: DTC -> DTC
57 call = Parent "call" "<call" "</call>"
58 code :: DTC -> DTC
59 code = Parent "code" "<code" "</code>"
60
61 -- * Type 'Date'
62 data Date
63 = Date
64 { date_year :: Int
65 , date_month :: Maybe Int
66 , date_day :: Maybe Int
67 } deriving (Eq,Show)
68 date :: Date -> DTC
69 date Date{..} =
70 Leaf "date" "<date" "/>" ()
71 ! attribute "year" " year=\"" (attrValue date_year)
72 !?? (date_month, attribute "month" " month=\"" . attrValue)
73 !?? (date_day, attribute "day" " day=\"" . attrValue)
74
75 define :: DTC -> DTC
76 define = Parent "define" "<define" "</define>"
77 document :: DTC -> DTC
78 document = Parent "document" "<document" "</document>"
79 editor :: DTC -> DTC
80 editor = Parent "editor" "<editor" "</editor>"
81 email :: DTC -> DTC
82 email = Parent "email" "<email" "</email>"
83 eref :: DTC -> DTC
84 eref = Parent "eref" "<eref" "</eref>"
85 i :: DTC -> DTC
86 i = Parent "i" "<i" "</i>"
87 include :: Bool -> AttributeValue -> DTC
88 include inc h =
89 Leaf "include" "<include" "/>" ()
90 !? (not inc, attribute "include" " include=\"" "no")
91 ! href h
92 keyword :: DTC -> DTC
93 keyword = Parent "keyword" "<keyword" "</keyword>"
94 li :: DTC -> DTC
95 li = Parent "li" "<li" "</li>"
96 link :: DTC -> DTC
97 link = Parent "link" "<link" "</link>"
98 macro :: DTC -> DTC
99 macro = Parent "macro" "<macro" "</macro>"
100 name :: DTC -> DTC
101 name = Parent "name" "<name" "</name>"
102 note :: DTC -> DTC
103 note = Parent "note" "<note" "</note>"
104 ol :: DTC -> DTC
105 ol = Parent "ol" "<ol" "</ol>"
106 organization :: DTC -> DTC
107 organization = Parent "organization" "<organization" "</organization>"
108 para :: DTC -> DTC
109 para = Parent "para" "<para" "</para>"
110 q :: DTC -> DTC
111 q = Parent "q" "<q" "</q>"
112 quote :: DTC -> DTC
113 quote = Parent "quote" "<quote" "</quote>"
114 ref :: DTC -> DTC
115 ref (Empty a) = Leaf "ref" "<ref" "/>" a
116 ref x = Parent "ref" "<ref" "</ref>" x
117 reference :: DTC -> DTC
118 reference = Parent "reference" "<reference" "</reference>"
119 references :: DTC -> DTC
120 references = Parent "references" "<references" "</references>"
121 rref :: DTC -> DTC
122 rref = Parent "rref" "<rref" "</rref>"
123 section :: DTC -> DTC
124 section = Parent "section" "<section" "</section>"
125 ul :: DTC -> DTC
126 ul = Parent "ul" "<ul" "</ul>"
127
128 -- * Type 'Postal'
129 data Postal
130 = Postal
131 { postal_street :: Text
132 , postal_zipcode :: Text
133 , postal_city :: Text
134 , postal_region :: Text
135 , postal_country :: Text
136 } deriving (Eq,Show)
137 postal :: Postal -> DTC
138 postal Postal{..} =
139 Parent "postal" "<postal" "</postal>" $ do
140 Parent "street" "<street" "</street>" $ toMarkup postal_street
141 Parent "zipcode" "<zipcode" "</zipcode>" $ toMarkup postal_zipcode
142 Parent "city" "<city" "</city>" $ toMarkup postal_city
143 Parent "region" "<region" "</region>" $ toMarkup postal_region
144 Parent "country" "<country" "</country>" $ toMarkup postal_country
145
146 indentTag :: Text -> IndentTag
147 indentTag t =
148 case t of
149 "about" -> IndentTagChildren
150 "address" -> IndentTagChildren
151 "author" -> IndentTagChildren
152 "document" -> IndentTagChildren
153 "ol" -> IndentTagChildren
154 "postal" -> IndentTagChildren
155 "section" -> IndentTagChildren
156 "ul" -> IndentTagChildren
157 "b" -> IndentTagText
158 "i" -> IndentTagText
159 "li" -> IndentTagText
160 "para" -> IndentTagText
161 "quote" -> IndentTagText
162 "note" -> IndentTagText
163 _ -> IndentTagPreserve