src/Symantic/Atom.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE NoMonomorphismRestriction #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE StrictData #-}
   8 {-# LANGUAGE TypeApplications #-}
   9 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Symantic.Atom where
  12
  13 import Control.Applicative (Applicative(..), Alternative((<|>)))
  14 import Control.Monad.Fail (MonadFail(..))
  15 import Data.Bool
  16 import Data.Eq (Eq)
  17 import Data.Either (Either(..))
  18 import Data.Function (($), (.))
  19 import Data.Functor ((<$>))
  20 import Data.Maybe (Maybe(..))
  21 import Data.Monoid (Monoid(..))
  22 import Data.Ord (Ord(..))
  23 import Data.String (IsString(..))
  24 import Data.Tuple (fst)
  25 import Text.Show (Show)
  26 import GHC.Generics (Generic)
  27 import qualified Data.Map.Strict as Map
  28 import qualified Data.Text.Lazy as TL
  29 import qualified Data.Tree as Tree
  30 import qualified Text.Megaparsec as P
  31 import qualified Text.Megaparsec.Char as P
  32 import qualified Data.Time.Clock as Time
  33 import qualified Data.Time.Format.ISO8601 as Time
  34
  35 import Symantic.XML hiding (Source, source)
  36 import Symantic.XML.RelaxNG
  37
  38 -- | Main symantic to be used.
  39 format =
  40   namespace Nothing xmlns_atom <.>
  41   namespace (Just "atom") xmlns_atom <.>
  42   namespace (Just "xhtml") xmlns_xhtml <.>
  43   namespace (Just "xsd") xmlns_xsd <.>
  44   namespace (Just "local") xmlns_local <.>
  45   start
  46
  47 start = feed <+> entry
  48
  49 elem = element . QName xmlns_atom
  50 attr = attribute . QName xmlns_empty
  51
  52 xmlns_atom  = "http://www.w3.org/2005/Atom"
  53 xmlns_xhtml = "http://www.w3.org/1999/xhtml"
  54 xmlns_local = ""
  55
  56 data Common
  57  =   Common
  58  {   base   :: Maybe URI
  59  ,   lang   :: Maybe LanguageTag
  60  ,   undefs :: [(QName, TL.Text)]
  61  } deriving (Show, Generic)
  62
  63 common =
  64   define "common" $
  65   adt @Common $
  66     attribute (QName xmlns_xml "base") uri <?&>
  67     attribute (QName xmlns_xml "lang") languageTag <?&>
  68     permWithDefault [] (many1 undefinedAttribute)
  69
  70 undefinedAttribute =
  71   define "undefinedAttribute" $
  72   construct (,) $
  73   attributeMatch
  74    ((*:*) :-: (xmlns_xml:::"base"
  75            :|: xmlns_xml:::"lang"
  76            :|: (:*) xmlns_local)
  77    ) text
  78
  79 newtype URI = URI TL.Text
  80  deriving (Eq,Show)
  81 instance DecodeText URI where
  82   decodeText = URI . fst <$> P.match (P.skipMany P.anySingle)
  83
  84 instance RNCText URI where
  85   -- | Unconstrained; it's not entirely clear how IRI fit into
  86   -- @xsd:anyURI@ so let's not try to constrain it here.
  87   rncText_qname = QName "" "text"
  88 uri =
  89   define "uri" $
  90   text @_ @URI
  91
  92 newtype LanguageTag = LanguageTag TL.Text
  93  deriving (Eq,Show)
  94 instance DecodeText LanguageTag where
  95   decodeText = LanguageTag . fst <$> P.match (
  96    P.count' 1 8 letter
  97     *> P.many (P.char '-' *> P.count' 1 8 letterNum))
  98     where
  99     letter = P.label "[A-Za-z]" $ P.satisfy $ \c ->
 100       'A' <= c && c <= 'Z' ||
 101       'a' <= c && c <= 'z'
 102     letterNum = P.label "[A-Za-z0-9]" $ P.satisfy $ \c ->
 103       'A' <= c && c <= 'Z' ||
 104       'a' <= c && c <= 'z' ||
 105       '0' <= c && c <= '9'
 106 instance RNCText LanguageTag where
 107   rncText_qname = QName xmlns_xsd "string"
 108   rncText_params = Map.fromList
 109    [ ("pattern", "[A-Za-z]{1,8}(-[A-Za-z0-9]{1,8})*") ]
 110 languageTag =
 111   define "languageTag" $
 112   text @_ @LanguageTag
 113
 114 data Text
 115  =   Text_Html  { text_common :: Common, text_content :: TL.Text }
 116  |   Text_Text  { text_common :: Common, text_content :: TL.Text }
 117  |   Text_Xhtml { text_common :: Common, text_content :: TL.Text }
 118  deriving (Show,Generic)
 119
 120 textConstruct =
 121   define "textConstruct" $
 122   adt @Text $
 123     type_ "html" <.> permutable common <:> text <+>
 124     type_ "xhtml" <.> permutable common <:> text <+> -- xhtmlDiv
 125     option (type_ "text") <.> permutable common <:> text
 126   where type_ t = attr "type" (literal t)
 127
 128 data Person
 129  =   Person
 130  {   person_name      :: TL.Text
 131  ,   person_uri       :: Maybe URI
 132  ,   person_email     :: Maybe Email
 133  ,   person_extension :: [Extension]
 134  ,   person_common    :: Common
 135  } deriving (Show,Generic)
 136
 137 person =
 138   define "person" $
 139   adt @Person $
 140   permutable $
 141     elem "name" text <&>
 142     elem "uri" uri <?&>
 143     elem "email" emailAddress <?&>
 144     extension <*&>
 145     common
 146
 147 newtype Email = Email TL.Text
 148  deriving (Eq,Ord,Show)
 149 instance DecodeText Email where
 150   decodeText = Email . fst <$> P.match (
 151     P.some c *> P.char '@' *> P.some c)
 152     where c = P.notFollowedBy (P.spaceChar <|> P.char '@') *> P.printChar
 153 instance RNCText Email where
 154   rncText_qname = QName xmlns_xsd "string"
 155   rncText_params = Map.fromList
 156    [ ("pattern", ".+@.+") ]
 157 emailAddress =
 158   define "emailAddress" $
 159   text @_ @Email
 160
 161 type DateTime = Time.UTCTime
 162 instance IsString str => MonadFail (Either str) where
 163   fail = Left . fromString
 164 instance DecodeText DateTime where
 165   decodeText = do
 166     t <- P.many P.anySingle
 167     Time.iso8601ParseM t
 168 instance RNCText DateTime where
 169   rncText_qname = QName xmlns_xsd "datetime"
 170 dateConstruct =
 171   define "dateConstruct" $
 172   permutable common <:>
 173   text @_ @DateTime
 174
 175 data Feed
 176  =   Feed
 177  {   feed_authors      :: [Person]
 178  ,   feed_categories   :: [Category]
 179  ,   feed_contributors :: [Person]
 180  ,   feed_generator    :: Maybe Generator
 181  ,   feed_icon         :: Maybe (Common, URI)
 182  ,   feed_id           :: (Common, URI)
 183  ,   feed_links        :: [Link]
 184  ,   feed_logo         :: Maybe (Common, URI)
 185  ,   feed_rights       :: Maybe Text
 186  ,   feed_subtitle     :: Maybe Text
 187  ,   feed_title        :: Text
 188  ,   feed_updated      :: (Common, DateTime)
 189  ,   feed_extensions   :: [Extension]
 190  ,   feed_entries      :: [Entry]
 191  ,   feed_common       :: Common
 192  } deriving (Show,Generic)
 193
 194 feed =
 195   define "feed" $
 196   elem "feed" $
 197   adt @Feed $
 198   permutable $
 199     author <*&>
 200     category <*&>
 201     contributor <*&>
 202     generator <?&>
 203     icon <?&>
 204     id <&>
 205     link <*&>
 206     logo <?&>
 207     rights <?&>
 208     subtitle <?&>
 209     title <&>
 210     updated <&>
 211     extension <*&>
 212     entry <*&>
 213     common
 214
 215 author =
 216   define "author" $
 217   elem "author" person
 218
 219 data Category
 220  =   Category
 221  {   category_term       :: TL.Text
 222  ,   category_scheme     :: Maybe URI
 223  ,   category_label      :: Maybe TL.Text
 224  ,   category_extensions :: [Extension]
 225  ,   category_common     :: Common
 226  } deriving (Show,Generic)
 227
 228 category =
 229   define "category" $
 230   elem "category" $
 231   adt @Category $
 232   permutable $
 233     attr "term" text <&>
 234     attr "scheme" uri <?&>
 235     attr "label" text <?&>
 236     extension <*&>
 237     common
 238
 239 contributor =
 240   define "contributor" $
 241   elem "contributor" person
 242
 243 data Generator
 244  =   Generator
 245  {   generator_uri     :: Maybe URI
 246  ,   generator_version :: Maybe TL.Text
 247  ,   generator_common  :: Common
 248  ,   generator_text    :: TL.Text
 249  } deriving (Show,Generic)
 250
 251 generator =
 252   define "generator" $
 253   elem "generator" $
 254   adt @Generator $
 255   permutable $
 256     attr "uri" uri <?&>
 257     attr "version" text <?&>
 258     common <:>
 259     perm text
 260
 261 icon =
 262   define "icon" $
 263   elem "icon" $
 264     permutable common <:>
 265     uri
 266
 267 id =
 268   define "id" $
 269   elem "id" $
 270     permutable common <:>
 271     uri
 272
 273 data Link
 274  =   Link
 275  {   link_href      :: URI
 276  ,   link_rel       :: Maybe (Either RelName URI)
 277  ,   link_type      :: Maybe MediaType
 278  ,   link_hreflang  :: Maybe LanguageTag
 279  ,   link_title     :: Maybe TL.Text
 280  ,   link_length    :: Maybe TL.Text
 281  ,   link_extension :: [Extension]
 282  ,   link_common    :: Common
 283  } deriving (Show,Generic)
 284
 285 link =
 286   define "link" $
 287   elem "link" $
 288   adt @Link $
 289   permutable $
 290     attr "href" uri <&>
 291     attr "rel" (relName <+> uri) <?&>
 292     attr "type" text <?&>
 293     attr "hreflang" languageTag <?&>
 294     attr "title" text <?&>
 295     attr "length" text <?&>
 296     extension <*&>
 297     common
 298
 299 newtype RelName = RelName TL.Text
 300  deriving (Eq,Show)
 301 instance DecodeText RelName where
 302   decodeText = RelName . fst <$> P.match (
 303     P.some $
 304     P.notFollowedBy (P.char ':' P.<|> P.spaceChar)
 305      *> P.printChar)
 306 instance RNCText RelName where
 307   rncText_qname = QName xmlns_xsd "string"
 308   rncText_params = Map.fromList
 309    [ ("minLength", "1")
 310    , ("pattern", "[^: ]*")
 311    ]
 312 relName =
 313   define "relName" $
 314   text @_ @RelName
 315
 316 newtype MediaType = MediaType TL.Text
 317  deriving (Eq,Show)
 318 instance DecodeText MediaType where
 319   decodeText = MediaType . fst <$> P.match (
 320     P.some c *> P.char '/' *> P.some c)
 321     where c = P.notFollowedBy (P.spaceChar <|> P.char '/') *> P.printChar
 322 instance RNCText MediaType where
 323   rncText_qname = QName xmlns_xsd "string"
 324   rncText_params = Map.fromList
 325    [ ("pattern", ".+/.+")
 326    ]
 327 mediaType =
 328   define "mediaType" $
 329   text @_ @MediaType
 330
 331 logo =
 332   define "logo" $
 333   elem "logo" $
 334     permutable common <:>
 335     uri
 336
 337 rights = elem "rights" textConstruct
 338
 339 subtitle = elem "subtitle" textConstruct
 340
 341 title = elem "title" textConstruct
 342
 343 updated = elem "updated" dateConstruct
 344
 345 data Entry
 346  =   Entry
 347  {   entry_authors      :: [Person]
 348  ,   entry_categories   :: [Category]
 349  ,   entry_content      :: Maybe (Common, Content)
 350  ,   entry_contributors :: [Person]
 351  ,   entry_id           :: (Common, URI)
 352  ,   entry_links        :: [Link]
 353  ,   entry_published    :: Maybe (Common, DateTime)
 354  ,   entry_rights       :: Maybe Text
 355  ,   entry_source       :: Maybe Source
 356  ,   entry_summary      :: Maybe Text
 357  ,   entry_title        :: Text
 358  ,   entry_updated      :: (Common, DateTime)
 359  ,   entry_extensions   :: [Extension]
 360  ,   entry_common       :: Common
 361  } deriving (Show,Generic)
 362
 363 entry =
 364   define "entry" $
 365   elem "entry" $
 366   adt @Entry $
 367   permutable $
 368     author <*&>
 369     category <*&>
 370     content <?&>
 371     contributor <*&>
 372     id <&>
 373     link <*&>
 374     published <?&>
 375     rights <?&>
 376     source <?&>
 377     summary <?&>
 378     title <&>
 379     updated <&>
 380     extension <*&>
 381     common
 382
 383 data Content
 384  =   Content_Text  TL.Text
 385  |   Content_Html  TL.Text
 386  |   Content_Xhtml XHTML
 387  |   Content_Src (Maybe MediaType) URI
 388  |   Content_Any (Maybe MediaType) (Either TL.Text Any)
 389  deriving (Show,Generic)
 390
 391 content =
 392   define "content" $
 393   elem "content" $
 394     permutable common <:>
 395     adt @Content (
 396       (type_ "text"  <.> text) <+>
 397       (type_ "html"  <.> text) <+>
 398       (type_ "xhtml" <.> divXHTML) <+>
 399       (optional mediaType <:> attr "src" uri <.> empty) <+>
 400       (optional mediaType <:> (text <+> anyNode))
 401     )
 402   where type_ t = attr "type" (literal t)
 403
 404 published = elem "published" dateConstruct
 405 summary = elem "summary" textConstruct
 406
 407 data Source
 408  =   Source
 409  {   source_authors      :: [Person]
 410  ,   source_categories   :: [Category]
 411  ,   source_contributors :: [Person]
 412  ,   source_generator    :: Maybe Generator
 413  ,   source_icon         :: Maybe (Common, URI)
 414  ,   source_id           :: Maybe (Common, URI)
 415  ,   source_links        :: [Link]
 416  ,   source_logo         :: Maybe (Common, URI)
 417  ,   source_rights       :: Maybe Text
 418  ,   source_subtitle     :: Maybe Text
 419  ,   source_title        :: Maybe Text
 420  ,   source_updated      :: Maybe (Common, DateTime)
 421  ,   source_extensions   :: [Extension]
 422  ,   source_common       :: Common
 423  } deriving (Show,Generic)
 424
 425 source =
 426   define "source" $
 427   elem "source" $
 428   adt @Source $
 429   permutable $
 430     author <*&>
 431     category <*&>
 432     contributor <*&>
 433     generator <?&>
 434     icon <?&>
 435     id <?&>
 436     link <*&>
 437     logo <?&>
 438     rights <?&>
 439     subtitle <?&>
 440     title <?&>
 441     updated <?&>
 442     extension <*&>
 443     common
 444
 445
 446 type Extension = (QName, ([(QName, TL.Text)], Tree.Forest AnyNode))
 447
 448 extension =
 449   define "extension" $
 450   construct (,) $
 451   elementMatch ((*:*) :-: (:*) xmlns_atom) $
 452     many0 (construct (,) (attributeMatch (*:*) text))
 453     <:>
 454     many0 anyNode
 455
 456 type Any = Tree.Tree AnyNode
 457 data AnyNode
 458  =   AnyNode_Elem QName [(QName, TL.Text)]
 459  |   AnyNode_Text TL.Text
 460  deriving (Show,Generic)
 461
 462 anyNode =
 463   define "anyNode" $
 464   adt @(Tree.Tree AnyNode) $
 465   dimap
 466    (\case
 467     Left (n,(as,ts)) -> (AnyNode_Elem n as, ts)
 468     Right t -> (AnyNode_Text t, mempty)
 469    )
 470    (\case
 471     (AnyNode_Elem n as, ts) -> Left (n,(as,ts))
 472     (AnyNode_Text t, _) -> Right t
 473    ) $
 474   construct (,) (elementMatch (*:*) (
 475     many0 (construct (,) (attributeMatch (*:*) text))
 476     <:>
 477     many0 anyNode
 478   ))
 479   <+> text
 480
 481 type XHTML = Tree.Tree XHTMLNode
 482 data XHTMLNode
 483  =   XHTMLNode_Elem QName [(QName, TL.Text)]
 484  |   XHTMLNode_Text TL.Text
 485  deriving (Show,Generic)
 486
 487 xhtmlNode =
 488   define "xhtmlNode" $
 489   adt @(Tree.Tree XHTMLNode) $
 490   dimap
 491    (\case
 492     Left (n,(as,ts)) -> (XHTMLNode_Elem n as, ts)
 493     Right t -> (XHTMLNode_Text t, mempty)
 494    )
 495    (\case
 496     (XHTMLNode_Elem n as, ts) -> Left (n,(as,ts))
 497     (XHTMLNode_Text t, _) -> Right t
 498    ) $
 499   construct (,) (elementMatch ((:*) xmlns_xhtml) (
 500     many0 (construct (,) (attributeMatch (*:*) text))
 501     <:>
 502     many0 xhtmlNode
 503   ))
 504   <+> text
 505
 506 divXHTML =
 507   define "divXHTML" $
 508   let div = QName xmlns_xhtml "div" in
 509   adt @(Tree.Tree XHTMLNode) $
 510   dimap
 511    (\case
 512     (as,Left ts) -> (XHTMLNode_Elem div as, ts)
 513     (_as,Right t) -> (XHTMLNode_Text t, mempty)
 514    )
 515    (\case
 516     (XHTMLNode_Elem _n as, ts) -> (as,Left ts)
 517     (XHTMLNode_Text t, _) -> (mempty,Right t)
 518    ) $
 519   element div $
 520     many0 (construct (,) (attributeMatch (*:*) text))
 521     <:>
 522     (many0 xhtmlNode <+> text)