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 Hdoc.DTC.Index (wordify)
  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                                                                 (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 Nothing <$> many para
 275                  , element "iref" $ Tree .  DTC.PlainIref Nothing . wordify <$> attribute "to" text <*> plain
 276                  , element "eref" $ Tree .  DTC.PlainEref <$> attribute "to" url <*> plain
 277                  , element "tag"  $ Tree .  DTC.PlainTag def <$> locationTCT <*> plain
 278                  , element "rref" $ Tree <$> (DTC.PlainRref Nothing Nothing <$> locationTCT <*> to) <*> plain
 279                  ]
 280         tag = rule "tag" $ element "tag" text
 281         about =
 282                 (foldr ($) def <$>) $
 283                 many $ choice
 284                  [ (\a acc -> acc{DTC.titles=a:DTC.titles acc})              <$> title
 285                  , (\a acc -> (acc::DTC.About){DTC.url=Just a})              <$> attribute "url" url
 286                  , (\a acc -> acc{DTC.authors=a:DTC.authors acc})            <$> author
 287                  , (\a acc -> acc{DTC.editor=DTC.editor acc Alt.<|> Just a}) <$> editor
 288                  , (\a acc -> acc{DTC.date=DTC.date acc Alt.<|> Just a})     <$> date
 289                  , (\a acc -> acc{DTC.tags=a:DTC.tags acc})                  <$> tag
 290                  , (\a acc -> acc{DTC.links=a:DTC.links acc})                <$> link
 291                  , (\a acc -> acc{DTC.series=a:DTC.series acc})              <$> serie
 292                  , (\a acc -> acc{DTC.headers=a:DTC.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 Nothing
 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 <$> title)
 357         choice_ =
 358                 rule "choice" $
 359                 element "choice" $
 360                 DTC.Choice
 361                  <$> locationTCT
 362                  <*> positionXML
 363                  <*> optional title
 364                  <*> many opinion
 365         opinion =
 366                 rule "opinion" $
 367                 element "opinion" $
 368                 (interleaved $ DTC.Opinion
 369                  <$$> locationTCT
 370                  <||> positionXML
 371                  <|?> (def, attribute "judge" name)
 372                  <|?> (def, attribute "grade" name)
 373                  <|?> (def, Just <$> attribute "importance" rationalPositive))
 374                  <*> optional title
 375         judges =
 376                 rule "judges" $
 377                 element "judges" $
 378                 DTC.Judges
 379                  <$> locationTCT
 380                  <*> positionXML
 381                  <*> commonAttrs
 382                  <*> judgesByName
 383                 where
 384                 judgesByName =
 385                         HM.fromListWith (flip (<>)) .
 386                         ((\j@DTC.Judge{..} -> (judge_name, pure j)) <$>)
 387                          <$> some judge
 388         judge =
 389                 rule "judge" $
 390                 element "judge" $
 391                 DTC.Judge
 392                  <$> locationTCT
 393                  <*> positionXML
 394                  <*> attribute "name" name
 395                  <*> optional title
 396                  <*> defaultGrades
 397                 where
 398                 defaultGrades =
 399                         HM.fromListWith (flip (<>)) .
 400                         (second pure <$>)
 401                          <$> many defaultGrade
 402                 defaultGrade =
 403                         rule "default" $
 404                         element "default" $
 405                         (,)
 406                          <$> attribute "grades" ident
 407                          <*> attribute "grade" (DTC.Name <$> text)
 408
 409 instance Sym_DTC RNC.Writer where
 410         positionXML = RNC.writeText ""
 411         locationTCT = RNC.writeText ""
 412 instance Sym_DTC RNC.RuleWriter where
 413         positionXML = RNC.RuleWriter positionXML
 414         locationTCT = RNC.RuleWriter locationTCT
 415
 416 -- | RNC schema for DTC
 417 schema :: [RNC.RuleWriter ()]
 418 schema =
 419  [ void $ document
 420
 421  , void $ head
 422  , void $ rule "about" $ element "about" about
 423  , void $ header
 424  , void $ tag
 425  , void $ author
 426  , void $ editor
 427  , void $ date
 428  , void $ entity
 429  , void $ link
 430  , void $ serie
 431  , void $ alias
 432  , void $ judgment
 433  , void $ choice_
 434  , void $ opinion
 435  , void $ judges
 436  , void $ judge
 437  , void $ grade
 438
 439  , void $ body
 440  , void $ include
 441
 442  , void $ block
 443  , void $ blockToC
 444  , void $ blockToF
 445  , void $ blockIndex
 446  , void $ blockFigure
 447  , void $ blockReferences
 448  , void $ reference
 449
 450  , void $ para
 451  , void $ paraItem
 452  , void $ paraItems
 453
 454  , void $ plain
 455  , void $ plainNode
 456
 457  , void $ commonAttrs
 458  , void $ ident
 459  , void $ title
 460  , void $ name
 461  , void $ url
 462  , void $ path
 463  , void $ to
 464  , void $ id
 465  ]