Hdoc/DTC/Sym.hs

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