Hdoc/DTC/Sym.hs

   1 {-# LANGUAGE DuplicateRecordFields #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 module Hdoc.DTC.Sym where
   6
   7 import Control.Applicative (Applicative(..), (<$>), (<$))
   8 import Control.Arrow (second)
   9 import Control.Monad (void)
  10 import Data.Bool (Bool(..))
  11 import Data.Default.Class (Default(..))
  12 import Data.Foldable (concat)
  13 import Data.Monoid (Monoid(..))
  14 import Data.Function (($), (.), flip)
  15 import Data.Maybe (Maybe(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.TreeSeq.Strict (Tree(..), tree0)
  18 import Language.Symantic.RNC hiding (element, attribute)
  19 import Text.Blaze.DTC (xmlns_dtc)
  20 import qualified Data.HashMap.Strict as HM
  21 import qualified Data.Text.Lazy as TL
  22 import qualified Language.Symantic.RNC as RNC
  23 import qualified Language.Symantic.RNC.Write as RNC
  24 import qualified Language.Symantic.XML as XML
  25
  26 import Hdoc.RNC as RNC
  27 import Hdoc.XML
  28 import qualified Hdoc.DTC.Analyze.Index as Index
  29 import qualified Hdoc.DTC.Document as DTC
  30 import qualified Hdoc.TCT.Cell as TCT
  31 import qualified Hdoc.XML as XML
  32
  33 element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
  34 element = RNC.element . XML.QName xmlns_dtc
  35 attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
  36 attribute = RNC.attribute . XML.QName ""
  37
  38 -- Class 'Sym_DTC'
  39 -- | Use a symantic (tagless final) class to encode
  40 -- both the parsing and the schema of DTC,
  41 -- when repr is respectively instanciated
  42 -- on 'DTC.Parser', 'RNC.NS' or 'RNC.Writer'.
  43 class (Sym_RNC repr, Sym_RNC_Extra repr) => Sym_DTC repr where
  44         positionXML      :: repr XML.Pos
  45         locationTCT      :: repr TCT.Location
  46         document         :: repr DTC.Document
  47
  48         head             :: repr DTC.Head
  49         body             :: repr DTC.Body
  50         section          :: repr DTC.Section
  51         about            :: repr DTC.About
  52         include          :: repr DTC.Include
  53
  54         block            :: repr DTC.Block
  55         blockBreak       :: repr DTC.Block
  56         blockToC         :: repr DTC.Block
  57         blockToF         :: repr DTC.Block
  58         blockIndex       :: repr DTC.Block
  59         blockAside       :: repr DTC.Block
  60         blockFigure      :: repr DTC.Block
  61         blockReferences  :: repr DTC.Block
  62         blockJudges      :: repr DTC.Block
  63         blockGrades      :: repr DTC.Block
  64         reference        :: repr DTC.Reference
  65
  66         para             :: repr DTC.Para
  67         paraItem         :: repr DTC.ParaItem
  68         paraItems        :: repr DTC.Para
  69
  70         plain            :: repr DTC.Plain
  71         plainNode        :: repr (Tree DTC.PlainNode)
  72
  73         commonAttrs      :: repr DTC.CommonAttrs
  74         ident            :: repr Ident
  75         title            :: repr DTC.Title
  76         name             :: repr DTC.Name
  77         url              :: repr URL
  78         path             :: repr DTC.FilePath
  79         to               :: repr Ident
  80         id               :: repr Ident
  81         class_           :: repr [TL.Text]
  82         rel              :: repr DTC.Name
  83         role             :: repr DTC.Name
  84
  85         author           :: repr DTC.Entity
  86         date             :: repr DTC.Date
  87         entity           :: repr DTC.Entity
  88         link             :: repr DTC.Link
  89         serie            :: repr DTC.Serie
  90         alias            :: repr DTC.Alias
  91         judgment         :: repr DTC.Judgment
  92         choice_          :: repr DTC.Choice
  93         opinion          :: repr DTC.Opinion
  94         judges           :: repr DTC.Judges
  95         judge            :: repr DTC.Judge
  96         grade            :: repr DTC.Grade
  97
  98         document = rule "document" $
  99                 DTC.Document
 100                  <$> optional head
 101                  <*> body
 102         head = rule "head" $
 103                 element "head" $
 104                 DTC.Head
 105                  <$> section
 106                  <*> body
 107         body = rule "body" $
 108                 manySeq $
 109                         choice
 110                          [ element "section" $ Tree . DTC.BodySection <$> section <*> body
 111                          , tree0 . DTC.BodyBlock <$> block
 112                          ]
 113         section = rule "section" $
 114                 interleaved $
 115                 (\section_posXML section_locTCT section_attrs abouts ->
 116                         DTC.Section{section_about=mconcat abouts, ..})
 117                  <$$> positionXML
 118                  <||> locationTCT
 119                  <||> commonAttrs
 120                  <|*> about
 121         about = rule "about" $
 122                 element "about" $
 123                 interleaved $
 124                 DTC.About
 125                  <$*> title
 126                  <|*> alias
 127                  <|*> author
 128                  <|*> date
 129                  <|*> element "tag" text
 130                  <|*> link
 131                  <|*> serie
 132                  <|*> element "description" para
 133                  <|*> judgment
 134         title = rule "title" $ DTC.Title <$> element "title" plain
 135         name  = rule "name"  $ DTC.Name <$> text
 136         url   = rule "url"   $ URL <$> text
 137         path  = rule "path"  $ TL.unpack <$> text
 138         ident = rule "ident" $ Ident <$> text
 139         to    = rule "to"    $ attribute "to" ident
 140         commonAttrs =
 141                 rule "commonAttrs" $
 142                 interleaved $
 143                 DTC.CommonAttrs
 144                  <$?> (def, Just <$> id)
 145                  <|?> (def, class_)
 146         id      = rule "id"    $ attribute "id" ident
 147         class_  = rule "class" $ attribute "class" $ TL.words <$> text
 148         rel     = rule "rel"   $ attribute "rel" name
 149         role    = rule "role"  $ attribute "role" name
 150
 151         date = rule "date" $
 152                 element "date" $
 153                 interleaved $
 154                 DTC.Date
 155                  <$?> (def, rel)
 156                  <|?> (def, role)
 157                  <||> attribute "year" int
 158                  <|?> (def, Just <$> attribute "month" nat1)
 159                  <|?> (def, Just <$> attribute "day"   nat1)
 160         include =
 161                 rule "include"  $
 162                 element "include" $
 163                 interleaved $
 164                 DTC.Include
 165                  <$?> (def, attribute "href" path)
 166         block = rule "block" $
 167                 choice
 168                  [ DTC.BlockPara <$> para
 169                  , blockBreak
 170                  , blockToC
 171                  , blockToF
 172                  , blockIndex
 173                  , blockAside
 174                  , blockFigure
 175                  , blockReferences
 176                  , blockJudges
 177                  , blockGrades
 178                  {-
 179                  , anyElem $ \n@XmlName{..} ->
 180                                 case xmlNameSpace of
 181                                  "" -> figure n
 182                  -}
 183                  ]
 184         blockBreak = rule "break" $
 185                 element "break" $
 186                 DTC.BlockBreak
 187                  <$> commonAttrs
 188         blockToC =
 189                 rule "blockToC" $
 190                 element "toc" $
 191                 DTC.BlockToC
 192                  <$> positionXML
 193                  <*> commonAttrs
 194                  <*> optional (attribute "depth" nat)
 195         blockToF =
 196                 rule "blockToF" $
 197                 element "tof" $
 198                 DTC.BlockToF
 199                  <$> positionXML
 200                  <*> commonAttrs
 201                  <*> option [] (
 202                         element "ul" $
 203                                 many $
 204                                         element "li" $
 205                                                 element "para" text)
 206         blockIndex =
 207                 rule "blockIndex" $
 208                 element "index" $
 209                 DTC.BlockIndex
 210                  <$> positionXML
 211                  <*> commonAttrs
 212                  <*> option [] (
 213                         element "ul" $
 214                                 many $
 215                                         element "li" $
 216                                                 element "para" $
 217                                                         indexWords
 218                  )
 219                 where
 220                 indexWords =
 221                         (concat <$>) $
 222                         many $
 223                                 (Index.wordify <$>) . TL.lines <$> text
 224                 {-
 225                 indexAt =
 226                 indexTag =
 227                 -}
 228         blockAside =
 229                 rule "blockAside" $
 230                 element "aside" $
 231                 DTC.BlockAside
 232                  <$> positionXML
 233                  <*> commonAttrs
 234                  <*> many block
 235         blockFigure =
 236                 rule "blockFigure" $
 237                 element "figure" $
 238                 DTC.BlockFigure
 239                  <$> positionXML
 240                  <*> attribute "type" text
 241                  <*> commonAttrs
 242                  <*> optional title
 243                  <*> many para
 244         blockReferences =
 245                 rule "blockReferences" $
 246                 element "references" $
 247                 DTC.BlockReferences
 248                  <$> positionXML
 249                  <*> commonAttrs
 250                  <*> many reference
 251         blockJudges = rule "blockJudges" $ DTC.BlockJudges <$> judges
 252         blockGrades =
 253                 rule "blockGrades" $
 254                 element "grades" $
 255                 DTC.BlockGrades
 256                  <$> positionXML
 257                  <*> commonAttrs
 258                  <*> some grade
 259         grade =
 260                 rule "grade" $
 261                 element "grade" $
 262                 DTC.Grade
 263                  <$> positionXML
 264                  <*> attribute "name" name
 265                  <*> attribute "color" text
 266                  <*> option False (True <$ attribute "default" text)
 267                  <*> optional title
 268
 269         para = rule "para" $
 270                 paraItems <|>             -- within  a <para>
 271                 DTC.ParaItem <$> paraItem -- without a <para>
 272         paraItem =
 273                 rule "paraItem" $
 274                 choice
 275                  [ element "ol"      $ DTC.ParaOL <$> many (element "li" $ DTC.ListItem <$> attribute "name" name <*> many para)
 276                  , element "ul"      $ DTC.ParaUL <$> many (element "li" $ many para)
 277                  , element "artwork" $ DTC.ParaArtwork <$> attribute "type" text <*> text
 278                  , element "quote"   $ DTC.ParaQuote   <$> attribute "type" text <*> many para
 279                  , DTC.ParaPlain <$> someSeq plainNode
 280                  , DTC.ParaComment <$> comment
 281                  , DTC.ParaJudgment <$> judgment
 282                  ]
 283         paraItems =
 284                 rule "paraItems" $
 285                 element "para" $
 286                         DTC.ParaItems
 287                          <$> positionXML
 288                          <*> commonAttrs
 289                          <*> many paraItem
 290         plain = rule "plain" $ manySeq plainNode
 291         plainNode =
 292                 rule "plainNode" $
 293                 choice
 294                  [ tree0 . DTC.PlainText <$> text
 295                  , element "br"   $ tree0   DTC.PlainBreak <$ empty
 296                  , element "b"    $ Tree    DTC.PlainB     <$> plain
 297                  , element "code" $ Tree    DTC.PlainCode  <$> plain
 298                  , element "del"  $ Tree    DTC.PlainDel   <$> plain
 299                  , element "i"    $ Tree    DTC.PlainI     <$> plain
 300                  , element "q"    $ Tree    DTC.PlainQ     <$> plain
 301                  , element "sc"   $ Tree    DTC.PlainSC    <$> plain
 302                  , element "span" $ Tree .  DTC.PlainSpan  <$> commonAttrs <*> plain
 303                  , element "sub"  $ Tree    DTC.PlainSub   <$> plain
 304                  , element "sup"  $ Tree    DTC.PlainSup   <$> plain
 305                  , element "u"    $ Tree    DTC.PlainU     <$> plain
 306                  , element "note" $ tree0 . DTC.PlainNote  <$> many para
 307                  , element "iref" $ Tree .  DTC.PlainIref . Index.wordify <$> attribute "to" text <*> plain
 308                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 309                  , element "tag"      $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure False)
 310                  , element "tag-back" $ tree0 <$> (DTC.PlainTag <$> locationTCT <*> positionXML <*> to <*> pure True )
 311                  , element "at"       $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure False)
 312                  , element "at-back"  $ tree0 <$> (DTC.PlainAt  <$> locationTCT <*> positionXML <*> to <*> pure True )
 313                  , element "ref"      $ Tree  <$> (DTC.PlainRef <$> locationTCT <*> positionXML <*> to) <*> plain
 314                  ]
 315         {-
 316         header =
 317                 rule "header" $
 318                 anyElem $ \n ->
 319                         DTC.Header (XML.nameLocal n)
 320                          <$> plain
 321         -}
 322         author = rule "author" $ element "author" entity
 323         entity = rule "entity" $
 324                 interleaved $
 325                 DTC.Entity
 326                  <$?> (def, rel)
 327                  <|?> (def, role)
 328                  <|?> (def, attribute "name"    text)
 329                  <|?> (def, attribute "street"  text)
 330                  <|?> (def, attribute "zipcode" text)
 331                  <|?> (def, attribute "city"    text)
 332                  <|?> (def, attribute "region"  text)
 333                  <|?> (def, attribute "country" text)
 334                  <|?> (def, attribute "email"   text)
 335                  <|?> (def, attribute "tel"     text)
 336                  <|?> (def, attribute "fax"     text)
 337                  <|?> (def, Just <$> attribute "url" url)
 338                  <|*> element "org" entity
 339         serie = rule "serie" $
 340                 element "serie" $
 341                 interleaved $
 342                 DTC.Serie
 343                  <$?> (def, attribute "name" name)
 344                  <|?> (def, attribute "id" text)
 345         link = rule "link" $
 346                 element "link" $
 347                 interleaved $
 348                 DTC.Link
 349                  <$?> (def, rel)
 350                  <|?> (def, role)
 351                  <|?> (def, attribute "url" url)
 352                  <|?> (def, someSeq plainNode)
 353         alias = rule "alias" $
 354                 element "alias" $
 355                 DTC.Alias
 356                  <$> commonAttrs
 357                  <*> title
 358         reference = rule "reference" $
 359                 element "reference" $
 360                 DTC.Reference
 361                  <$> positionXML
 362                  <*> locationTCT
 363                  <*> id
 364                  <*> about
 365
 366         judgment =
 367                 rule "judgment" $
 368                 element "judgment" $
 369                 attrs
 370                  <*> many choice_
 371                 where
 372                 attrs =
 373                         interleaved $
 374                         DTC.Judgment def -- def def
 375                          <$$> positionXML
 376                          <||> locationTCT
 377                          <||> attribute "judges" ident
 378                          <||> attribute "grades" ident
 379                          <|?> (def, Just <$> attribute "importance" rationalPositive)
 380                          <|?> (def, Just <$> attribute "hide" bool)
 381                          -- <|?> (def, Just <$> attribute "importance" (pure 0))
 382                          <|?> (def, Just <$> title)
 383         choice_ =
 384                 rule "choice" $
 385                 element "choice" $
 386                 DTC.Choice
 387                  <$> locationTCT
 388                  <*> positionXML
 389                  <*> optional title
 390                  <*> many opinion
 391         opinion =
 392                 rule "opinion" $
 393                 element "opinion" $
 394                 (interleaved $ DTC.Opinion
 395                  <$$> locationTCT
 396                  <||> positionXML
 397                  <|?> (def, attribute "judge" name)
 398                  <|?> (def, attribute "grade" name)
 399                  <|?> (def, Just <$> attribute "default" name)
 400                  <|?> (def, Just <$> attribute "importance" rationalPositive))
 401                  -- <|?> (def, Just <$> attribute "importance" (pure 0)))
 402                  <*> optional title
 403         judges =
 404                 rule "judges" $
 405                 element "judges" $
 406                 DTC.Judges
 407                  <$> locationTCT
 408                  <*> positionXML
 409                  <*> commonAttrs
 410                  <*> judgesByName
 411                 where
 412                 judgesByName =
 413                         HM.fromListWith (flip (<>)) .
 414                         ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
 415                          <$> some judge
 416         judge =
 417                 rule "judge" $
 418                 element "judge" $
 419                 DTC.Judge
 420                  <$> locationTCT
 421                  <*> positionXML
 422                  <*> attribute "name" name
 423                  <*> optional title
 424                  <*> defaultGrades
 425                 where
 426                 defaultGrades =
 427                         HM.fromListWith (flip (<>)) .
 428                         (second pure <$>)
 429                          <$> many defaultGrade
 430                 defaultGrade =
 431                         rule "default" $
 432                         element "default" $
 433                         (,)
 434                          <$> attribute "grades" ident
 435                          <*> attribute "grade" (DTC.Name <$> text)
 436
 437 instance Sym_DTC RNC.NS where
 438         positionXML = mempty
 439         locationTCT = mempty
 440 instance Sym_DTC RNC.Writer where
 441         positionXML = RNC.writeText ""
 442         locationTCT = RNC.writeText ""
 443
 444 -- | RNC schema for DTC
 445 schema :: forall repr. Sym_DTC repr => [repr ()]
 446 schema =
 447  [ void $ RNC.namespace Nothing xmlns_dtc
 448
 449  , void $ document
 450  , void $ about
 451  , void $ author
 452  , void $ date
 453  , void $ entity
 454  , void $ link
 455  , void $ serie
 456  , void $ alias
 457  , void $ judgment
 458  , void $ choice_
 459  , void $ opinion
 460  , void $ judges
 461  , void $ judge
 462  , void $ grade
 463
 464  , void $ head
 465  , void $ body
 466  , void $ section
 467  , void $ include
 468
 469  , void $ block
 470  , void $ blockToC
 471  , void $ blockToF
 472  , void $ blockIndex
 473  , void $ blockFigure
 474  , void $ blockReferences
 475  , void $ reference
 476
 477  , void $ para
 478  , void $ paraItem
 479  , void $ paraItems
 480
 481  , void $ plain
 482  , void $ plainNode
 483
 484  , void $ commonAttrs
 485  , void $ ident
 486  , void $ title
 487  , void $ name
 488  , void $ url
 489  , void $ path
 490  , void $ to
 491  , void $ id
 492  , void $ class_
 493  , void $ rel
 494  ]