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