src/Textphile/DTC/Sym.hs

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