Text/Blaze/DTC.hs

   1 {-# LANGUAGE OverloadedLists #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Text.Blaze.DTC where
   5
   6 import Data.Bool
   7 import Data.Text (Text)
   8 import Text.Blaze
   9 import Text.Blaze.Internal
  10
  11 import Text.Blaze.Utils
  12 import Text.Blaze.XML (XML)
  13
  14 import Hdoc.DTC.Document
  15
  16 -- * Type 'DTC'
  17 type DTC = Text.Blaze.XML.XML
  18
  19 xmlModel :: Text -> DTC
  20 xmlModel rnc =
  21         Leaf "xml-model" "<?xml-model" "?>\n" ()
  22          ! attribute "type" " type=\"" "application/relax-ng-compact-syntax"
  23          ! attribute "href" " href=\"" (attrify rnc)
  24
  25 xmlStylesheet :: Text -> DTC
  26 xmlStylesheet xsl =
  27         Leaf "xml-stylesheet" "<?xml-stylesheet" "?>\n" ()
  28          ! attribute "type" " type=\"" "text/xsl"
  29          ! attribute "href" " href=\"" (attrify xsl)
  30
  31 html5Stylesheet :: Text -> DTC
  32 html5Stylesheet xsl =
  33         Leaf "html5-stylesheet" "<?html5-stylesheet" "?>\n" ()
  34          ! attribute "type" " type=\"" "text/xsl"
  35          ! attribute "href" " href=\"" (attrify xsl)
  36
  37 atomStylesheet :: Text -> DTC
  38 atomStylesheet xsl =
  39         Leaf "atom-stylesheet" "<?atom-stylesheet" "?>\n" ()
  40          ! attribute "type" " type=\"" "text/xsl"
  41          ! attribute "href" " href=\"" (attrify xsl)
  42
  43 about :: DTC -> DTC
  44 about = Parent "about" "<about" "</about>"
  45 alias :: DTC -> DTC
  46 alias = Parent "alias" "<alias" "</alias>"
  47 at :: DTC -> DTC
  48 at = Parent "at" "<at" "</at>"
  49 at_back :: DTC -> DTC
  50 at_back = Parent "at-back" "<at-back" "</at-back>"
  51 artwork :: DTC -> DTC
  52 artwork = Parent "artwork" "<artwork" "</artwork>"
  53 aside :: DTC -> DTC
  54 aside = Parent "aside" "<aside" "</aside>"
  55 author :: DTC -> DTC
  56 author = Parent "author" "<author" "</author>"
  57 b :: DTC -> DTC
  58 b = Parent "b" "<b" "</b>"
  59 br :: DTC
  60 br = Leaf "br" "<br" " />" ()
  61 break :: DTC
  62 break = Leaf "break" "<break" " />" ()
  63 call :: DTC -> DTC
  64 call = Parent "call" "<call" "</call>"
  65 code :: DTC -> DTC
  66 code = Parent "code" "<code" "</code>"
  67 comment :: Text -> DTC
  68 comment t = Comment (Text t) ()
  69 date :: DTC
  70 date = Leaf "date" "<date" "/>" ()
  71 define :: DTC -> DTC
  72 define = Parent "define" "<define" "</define>"
  73 del :: DTC -> DTC
  74 del = Parent "del" "<del" "</del>"
  75 document :: DTC -> DTC
  76 document = Parent "document" "<document" "</document>"
  77 editor :: DTC -> DTC
  78 editor = Parent "editor" "<editor" "</editor>"
  79 email :: DTC -> DTC
  80 email = Parent "email" "<email" "</email>"
  81 entity :: DTC -> DTC
  82 entity = Parent "entity" "<entity" "</entity>"
  83 eref :: DTC -> DTC
  84 eref (Empty a) = Leaf "eref" "<eref" "/>" a
  85 eref x = Parent "eref" "<eref" "</eref>" x
  86 figure :: DTC -> DTC
  87 figure = Parent "figure" "<figure" "</figure>"
  88 grades :: DTC -> DTC
  89 grades = Parent "grades" "<grades" "</grades>"
  90 head :: DTC -> DTC
  91 head = Parent "head" "<head" "</head>"
  92 i :: DTC -> DTC
  93 i = Parent "i" "<i" "</i>"
  94 include :: Bool -> DTC
  95 include inc = Leaf "include" "<include" "/>" () !? (not inc, attribute "include" " include=\"" "no")
  96 index :: DTC -> DTC
  97 index = Parent "index" "<index" "</index>"
  98 iref :: DTC -> DTC
  99 iref (Empty a) = Leaf "iref" "<iref" "/>" a
 100 iref x = Parent "iref" "<iref" "</iref>" x
 101 judges :: DTC -> DTC
 102 judges = Parent "judges" "<judges" "</judges>"
 103 judgment :: DTC -> DTC
 104 judgment = Parent "judgment" "<judgment" "</judgment>"
 105 li :: DTC -> DTC
 106 li = Parent "li" "<li" "</li>"
 107 link :: DTC -> DTC
 108 link = Parent "link" "<link" "</link>"
 109 macro :: DTC -> DTC
 110 macro = Parent "macro" "<macro" "</macro>"
 111 note :: DTC -> DTC
 112 note = Parent "note" "<note" "</note>"
 113 ol :: DTC -> DTC
 114 ol = Parent "ol" "<ol" "</ol>"
 115 organization :: DTC -> DTC
 116 organization = Parent "organization" "<organization" "</organization>"
 117 p :: DTC -> DTC
 118 p = Parent "p" "<p" "</p>"
 119 para :: DTC -> DTC
 120 para = Parent "para" "<para" "</para>"
 121 q :: DTC -> DTC
 122 q = Parent "q" "<q" "</q>"
 123 quote :: DTC -> DTC
 124 quote = Parent "quote" "<quote" "</quote>"
 125 ref :: DTC -> DTC
 126 ref (Empty a) = Leaf "ref" "<ref" "/>" a
 127 ref x = Parent "ref" "<ref" "</ref>" x
 128 reference :: DTC -> DTC
 129 reference = Parent "reference" "<reference" "</reference>"
 130 references :: DTC -> DTC
 131 references = Parent "references" "<references" "</references>"
 132 refs :: DTC -> DTC
 133 refs = Parent "refs" "<refs" "</refs>"
 134 sc :: DTC -> DTC
 135 sc = Parent "sc" "<sc" "</sc>"
 136 section :: DTC -> DTC
 137 section = Parent "section" "<section" "</section>"
 138 span :: DTC -> DTC
 139 span = Parent "span" "<span" "</span>"
 140 sub :: DTC -> DTC
 141 sub = Parent "sub" "<sub" "</sub>"
 142 sup :: DTC -> DTC
 143 sup = Parent "sup" "<sup" "</sup>"
 144 tag :: DTC -> DTC
 145 -- tag (Empty a) = Leaf "tag" "<tag" "/>" a
 146 tag = Parent "tag" "<tag" "</tag>"
 147 tag_back :: DTC -> DTC
 148 tag_back = Parent "tag-back" "<tag-back" "</tag-back>"
 149 title :: DTC -> DTC
 150 title = Parent "title" "<title" "</title>"
 151 toc :: DTC
 152 toc = Leaf "toc" "<toc" "/>" ()
 153 tof :: DTC -> DTC
 154 tof = Parent "tof" "<tof" "</tof>"
 155 u :: DTC -> DTC
 156 u = Parent "u" "<u" "</u>"
 157 ul :: DTC -> DTC
 158 ul = Parent "ul" "<ul" "</ul>"
 159 version :: DTC -> DTC
 160 version = Parent "version" "<version" "</version>"
 161
 162 isInlinedElement :: Text -> Bool
 163 isInlinedElement = \case
 164  "a"    -> True
 165  "b"    -> True
 166  "br"   -> True
 167  "code" -> True
 168  "em"   -> True
 169  "i"    -> True
 170  "note" -> True
 171  "q"    -> True
 172  "u"    -> True
 173  "sup"  -> True
 174  "sub"  -> True
 175  _      -> False
 176
 177 instance Attrify Name where
 178         attrify (Name a) = attrify a
 179 instance MayAttr Name where
 180         mayAttr a (Name t) = mayAttr a t