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