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
13 import Control.Applicative (Applicative(..), Alternative((<|>)))
14 import Control.Monad.Fail (MonadFail(..))
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
35 import Symantic.XML hiding (Source, source)
36 import Symantic.XML.RelaxNG
38 -- | Main symantic to be used.
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 <.>
47 start = feed <+> entry
49 elem = element . QName xmlns_atom
50 attr = attribute . QName xmlns_empty
52 xmlns_atom = "http://www.w3.org/2005/Atom"
53 xmlns_xhtml = "http://www.w3.org/1999/xhtml"
59 , lang :: Maybe LanguageTag
60 , undefs :: [(QName, TL.Text)]
61 } deriving (Show, Generic)
66 attribute (QName xmlns_xml "base") uri <?&>
67 attribute (QName xmlns_xml "lang") languageTag <?&>
68 permWithDefault [] (many1 undefinedAttribute)
71 define "undefinedAttribute" $
74 ((*:*) :-: (xmlns_xml:::"base"
75 :|: xmlns_xml:::"lang"
79 newtype URI = URI TL.Text
81 instance DecodeText URI where
82 decodeText = URI . fst <$> P.match (P.skipMany P.anySingle)
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"
92 newtype LanguageTag = LanguageTag TL.Text
94 instance DecodeText LanguageTag where
95 decodeText = LanguageTag . fst <$> P.match (
97 *> P.many (P.char '-' *> P.count' 1 8 letterNum))
99 letter = P.label "[A-Za-z]" $ P.satisfy $ \c ->
100 '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' ||
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})*") ]
111 define "languageTag" $
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)
121 define "textConstruct" $
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)
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)
143 elem "email" emailAddress <?&>
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", ".+@.+") ]
158 define "emailAddress" $
161 type DateTime = Time.UTCTime
162 instance IsString str => MonadFail (Either str) where
163 fail = Left . fromString
164 instance DecodeText DateTime where
166 t <- P.many P.anySingle
168 instance RNCText DateTime where
169 rncText_qname = QName xmlns_xsd "datetime"
171 define "dateConstruct" $
172 permutable common <:>
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
188 , feed_updated :: (Common, DateTime)
189 , feed_extensions :: [Extension]
190 , feed_entries :: [Entry]
191 , feed_common :: Common
192 } deriving (Show,Generic)
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)
234 attr "scheme" uri <?&>
235 attr "label" text <?&>
240 define "contributor" $
241 elem "contributor" person
245 { generator_uri :: Maybe URI
246 , generator_version :: Maybe TL.Text
247 , generator_common :: Common
248 , generator_text :: TL.Text
249 } deriving (Show,Generic)
257 attr "version" text <?&>
264 permutable common <:>
270 permutable common <:>
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)
291 attr "rel" (relName <+> uri) <?&>
292 attr "type" text <?&>
293 attr "hreflang" languageTag <?&>
294 attr "title" text <?&>
295 attr "length" text <?&>
299 newtype RelName = RelName TL.Text
301 instance DecodeText RelName where
302 decodeText = RelName . fst <$> P.match (
304 P.notFollowedBy (P.char ':' P.<|> P.spaceChar)
306 instance RNCText RelName where
307 rncText_qname = QName xmlns_xsd "string"
308 rncText_params = Map.fromList
310 , ("pattern", "[^: ]*")
316 newtype MediaType = MediaType TL.Text
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", ".+/.+")
334 permutable common <:>
337 rights = elem "rights" textConstruct
339 subtitle = elem "subtitle" textConstruct
341 title = elem "title" textConstruct
343 updated = elem "updated" dateConstruct
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)
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)
394 permutable common <:>
396 (type_ "text" <.> text) <+>
397 (type_ "html" <.> text) <+>
398 (type_ "xhtml" <.> divXHTML) <+>
399 (optional mediaType <:> attr "src" uri <.> empty) <+>
400 (optional mediaType <:> (text <+> anyNode))
402 where type_ t = attr "type" (literal t)
404 published = elem "published" dateConstruct
405 summary = elem "summary" textConstruct
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)
446 type Extension = (QName, ([(QName, TL.Text)], Tree.Forest AnyNode))
451 elementMatch ((*:*) :-: (:*) xmlns_atom) $
452 many0 (construct (,) (attributeMatch (*:*) text))
456 type Any = Tree.Tree AnyNode
458 = AnyNode_Elem QName [(QName, TL.Text)]
459 | AnyNode_Text TL.Text
460 deriving (Show,Generic)
464 adt @(Tree.Tree AnyNode) $
467 Left (n,(as,ts)) -> (AnyNode_Elem n as, ts)
468 Right t -> (AnyNode_Text t, mempty)
471 (AnyNode_Elem n as, ts) -> Left (n,(as,ts))
472 (AnyNode_Text t, _) -> Right t
474 construct (,) (elementMatch (*:*) (
475 many0 (construct (,) (attributeMatch (*:*) text))
481 type XHTML = Tree.Tree XHTMLNode
483 = XHTMLNode_Elem QName [(QName, TL.Text)]
484 | XHTMLNode_Text TL.Text
485 deriving (Show,Generic)
489 adt @(Tree.Tree XHTMLNode) $
492 Left (n,(as,ts)) -> (XHTMLNode_Elem n as, ts)
493 Right t -> (XHTMLNode_Text t, mempty)
496 (XHTMLNode_Elem n as, ts) -> Left (n,(as,ts))
497 (XHTMLNode_Text t, _) -> Right t
499 construct (,) (elementMatch ((:*) xmlns_xhtml) (
500 many0 (construct (,) (attributeMatch (*:*) text))
508 let div = QName xmlns_xhtml "div" in
509 adt @(Tree.Tree XHTMLNode) $
512 (as,Left ts) -> (XHTMLNode_Elem div as, ts)
513 (_as,Right t) -> (XHTMLNode_Text t, mempty)
516 (XHTMLNode_Elem _n as, ts) -> (as,Left ts)
517 (XHTMLNode_Text t, _) -> (mempty,Right t)
520 many0 (construct (,) (attributeMatch (*:*) text))
522 (many0 xhtmlNode <+> text)