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                  , element "page-ref" $ Tree  <$> (DTC.PlainPageRef <$> locationTCT <*> positionXML
 315                                                                     <*> optional (attribute "at" ident)
 316                                                                     <*> attribute "page" text
 317                                                                     ) <*> plain
 318                  ]
 319         {-
 320         header =
 321                 rule "header" $
 322                 anyElem $ \n ->
 323                         DTC.Header (XML.nameLocal n)
 324                          <$> plain
 325         -}
 326         author = rule "author" $ element "author" entity
 327         entity = rule "entity" $
 328                 interleaved $
 329                 DTC.Entity
 330                  <$?> (def, rel)
 331                  <|?> (def, role)
 332                  <|?> (def, attribute "name"    text)
 333                  <|?> (def, attribute "street"  text)
 334                  <|?> (def, attribute "zipcode" text)
 335                  <|?> (def, attribute "city"    text)
 336                  <|?> (def, attribute "region"  text)
 337                  <|?> (def, attribute "country" text)
 338                  <|?> (def, attribute "email"   text)
 339                  <|?> (def, attribute "tel"     text)
 340                  <|?> (def, attribute "fax"     text)
 341                  <|?> (def, Just <$> attribute "url" url)
 342                  <|*> element "org" entity
 343         serie = rule "serie" $
 344                 element "serie" $
 345                 interleaved $
 346                 DTC.Serie
 347                  <$?> (def, attribute "name" name)
 348                  <|?> (def, attribute "id" text)
 349         link = rule "link" $
 350                 element "link" $
 351                 interleaved $
 352                 DTC.Link
 353                  <$?> (def, rel)
 354                  <|?> (def, role)
 355                  <|?> (def, attribute "url" url)
 356                  <|?> (def, someSeq plainNode)
 357         alias = rule "alias" $
 358                 element "alias" $
 359                 DTC.Alias
 360                  <$> commonAttrs
 361                  <*> title
 362         reference = rule "reference" $
 363                 element "reference" $
 364                 DTC.Reference
 365                  <$> positionXML
 366                  <*> locationTCT
 367                  <*> id
 368                  <*> about
 369
 370         judgment =
 371                 rule "judgment" $
 372                 element "judgment" $
 373                 attrs
 374                  <*> many choice_
 375                 where
 376                 attrs =
 377                         interleaved $
 378                         DTC.Judgment def -- def def
 379                          <$$> positionXML
 380                          <||> locationTCT
 381                          <||> attribute "judges" ident
 382                          <||> attribute "grades" ident
 383                          <|?> (def, Just <$> attribute "importance" rationalPositive)
 384                          <|?> (def, Just <$> attribute "hide" bool)
 385                          -- <|?> (def, Just <$> attribute "importance" (pure 0))
 386                          <|?> (def, Just <$> title)
 387         choice_ =
 388                 rule "choice" $
 389                 element "choice" $
 390                 DTC.Choice
 391                  <$> locationTCT
 392                  <*> positionXML
 393                  <*> optional title
 394                  <*> many opinion
 395         opinion =
 396                 rule "opinion" $
 397                 element "opinion" $
 398                 (interleaved $ DTC.Opinion
 399                  <$$> locationTCT
 400                  <||> positionXML
 401                  <|?> (def, attribute "judge" name)
 402                  <|?> (def, attribute "grade" name)
 403                  <|?> (def, Just <$> attribute "default" name)
 404                  <|?> (def, Just <$> attribute "importance" rationalPositive))
 405                  -- <|?> (def, Just <$> attribute "importance" (pure 0)))
 406                  <*> optional title
 407         judges =
 408                 rule "judges" $
 409                 element "judges" $
 410                 DTC.Judges
 411                  <$> locationTCT
 412                  <*> positionXML
 413                  <*> commonAttrs
 414                  <*> judgesByName
 415                 where
 416                 judgesByName =
 417                         HM.fromListWith (flip (<>)) .
 418                         ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
 419                          <$> some judge
 420         judge =
 421                 rule "judge" $
 422                 element "judge" $
 423                 DTC.Judge
 424                  <$> locationTCT
 425                  <*> positionXML
 426                  <*> attribute "name" name
 427                  <*> optional title
 428                  <*> defaultGrades
 429                 where
 430                 defaultGrades =
 431                         HM.fromListWith (flip (<>)) .
 432                         (second pure <$>)
 433                          <$> many defaultGrade
 434                 defaultGrade =
 435                         rule "default" $
 436                         element "default" $
 437                         (,)
 438                          <$> attribute "grades" ident
 439                          <*> attribute "grade" (DTC.Name <$> text)
 440
 441 instance Sym_DTC RNC.NS where
 442         positionXML = mempty
 443         locationTCT = mempty
 444 instance Sym_DTC RNC.Writer where
 445         positionXML = RNC.writeText ""
 446         locationTCT = RNC.writeText ""
 447
 448 -- | RNC schema for DTC
 449 schema :: forall repr. Sym_DTC repr => [repr ()]
 450 schema =
 451  [ void $ RNC.namespace Nothing xmlns_dtc
 452
 453  , void $ document
 454  , void $ about
 455  , void $ author
 456  , void $ date
 457  , void $ entity
 458  , void $ link
 459  , void $ serie
 460  , void $ alias
 461  , void $ judgment
 462  , void $ choice_
 463  , void $ opinion
 464  , void $ judges
 465  , void $ judge
 466  , void $ grade
 467
 468  , void $ head
 469  , void $ body
 470  , void $ section
 471  , void $ include
 472
 473  , void $ block
 474  , void $ blockToC
 475  , void $ blockToF
 476  , void $ blockIndex
 477  , void $ blockFigure
 478  , void $ blockReferences
 479  , void $ reference
 480
 481  , void $ para
 482  , void $ paraItem
 483  , void $ paraItems
 484
 485  , void $ plain
 486  , void $ plainNode
 487
 488  , void $ commonAttrs
 489  , void $ ident
 490  , void $ title
 491  , void $ name
 492  , void $ url
 493  , void $ path
 494  , void $ to
 495  , void $ id
 496  , void $ class_
 497  , void $ rel
 498  ]