{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Atom where
import Control.Applicative (Applicative(..), Alternative((<|>)))
import Control.Monad.Fail (MonadFail(..))
import Data.Bool
import Data.Eq (Eq)
import Data.Either (Either(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.String (IsString(..))
import Data.Tuple (fst)
import Text.Show (Show)
import GHC.Generics (Generic)
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as TL
import qualified Data.Tree as Tree
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Data.Time.Clock as Time
import qualified Data.Time.Format.ISO8601 as Time
import Symantic.XML hiding (Source, source)
import Symantic.XML.RelaxNG
format =
namespace Nothing xmlns_atom <.>
namespace (Just "atom") xmlns_atom <.>
namespace (Just "xhtml") xmlns_xhtml <.>
namespace (Just "xsd") xmlns_xsd <.>
namespace (Just "local") xmlns_local <.>
start
start = feed <+> entry
elem = element . QName xmlns_atom
attr = attribute . QName xmlns_empty
xmlns_atom = "http://www.w3.org/2005/Atom"
xmlns_xhtml = "http://www.w3.org/1999/xhtml"
xmlns_local = ""
data Common
= Common
{ base :: Maybe URI
, lang :: Maybe LanguageTag
, undefs :: [(QName, TL.Text)]
} deriving (Show, Generic)
common =
define "common" $
adt @Common $
attribute (QName xmlns_xml "base") uri <?&>
attribute (QName xmlns_xml "lang") languageTag <?&>
permWithDefault [] (many1 undefinedAttribute)
undefinedAttribute =
define "undefinedAttribute" $
construct (,) $
attributeMatch
((*:*) :-: (xmlns_xml:::"base"
:|: xmlns_xml:::"lang"
:|: (:*) xmlns_local)
) text
newtype URI = URI TL.Text
deriving (Eq,Show)
instance DecodeText URI where
decodeText = URI . fst <$> P.match (P.skipMany P.anySingle)
instance RNCText URI where
rncText_qname = QName "" "text"
uri =
define "uri" $
text @_ @URI
newtype LanguageTag = LanguageTag TL.Text
deriving (Eq,Show)
instance DecodeText LanguageTag where
decodeText = LanguageTag . fst <$> P.match (
P.count' 1 8 letter
*> P.many (P.char '-' *> P.count' 1 8 letterNum))
where
letter = P.label "[A-Za-z]" $ P.satisfy $ \c ->
'A' <= c && c <= 'Z' ||
'a' <= c && c <= 'z'
letterNum = P.label "[A-Za-z0-9]" $ P.satisfy $ \c ->
'A' <= c && c <= 'Z' ||
'a' <= c && c <= 'z' ||
'0' <= c && c <= '9'
instance RNCText LanguageTag where
rncText_qname = QName xmlns_xsd "string"
rncText_params = Map.fromList
[ ("pattern", "[A-Za-z]{1,8}(-[A-Za-z0-9]{1,8})*") ]
languageTag =
define "languageTag" $
text @_ @LanguageTag
data Text
= Text_Html { text_common :: Common, text_content :: TL.Text }
| Text_Text { text_common :: Common, text_content :: TL.Text }
| Text_Xhtml { text_common :: Common, text_content :: TL.Text }
deriving (Show,Generic)
textConstruct =
define "textConstruct" $
adt @Text $
type_ "html" <.> permutable common <:> text <+>
type_ "xhtml" <.> permutable common <:> text <+>
option (type_ "text") <.> permutable common <:> text
where type_ t = attr "type" (literal t)
data Person
= Person
{ person_name :: TL.Text
, person_uri :: Maybe URI
, person_email :: Maybe Email
, person_extension :: [Extension]
, person_common :: Common
} deriving (Show,Generic)
person =
define "person" $
adt @Person $
permutable $
elem "name" text <&>
elem "uri" uri <?&>
elem "email" emailAddress <?&>
extension <*&>
common
newtype Email = Email TL.Text
deriving (Eq,Ord,Show)
instance DecodeText Email where
decodeText = Email . fst <$> P.match (
P.some c *> P.char '@' *> P.some c)
where c = P.notFollowedBy (P.spaceChar <|> P.char '@') *> P.printChar
instance RNCText Email where
rncText_qname = QName xmlns_xsd "string"
rncText_params = Map.fromList
[ ("pattern", ".+@.+") ]
emailAddress =
define "emailAddress" $
text @_ @Email
type DateTime = Time.UTCTime
instance IsString str => MonadFail (Either str) where
fail = Left . fromString
instance DecodeText DateTime where
decodeText = do
t <- P.many P.anySingle
Time.iso8601ParseM t
instance RNCText DateTime where
rncText_qname = QName xmlns_xsd "datetime"
dateConstruct =
define "dateConstruct" $
permutable common <:>
text @_ @DateTime
data Feed
= Feed
{ feed_authors :: [Person]
, feed_categories :: [Category]
, feed_contributors :: [Person]
, feed_generator :: Maybe Generator
, feed_icon :: Maybe (Common, URI)
, feed_id :: (Common, URI)
, feed_links :: [Link]
, feed_logo :: Maybe (Common, URI)
, feed_rights :: Maybe Text
, feed_subtitle :: Maybe Text
, feed_title :: Text
, feed_updated :: (Common, DateTime)
, feed_extensions :: [Extension]
, feed_entries :: [Entry]
, feed_common :: Common
} deriving (Show,Generic)
feed =
define "feed" $
elem "feed" $
adt @Feed $
permutable $
author <*&>
category <*&>
contributor <*&>
generator <?&>
icon <?&>
id <&>
link <*&>
logo <?&>
rights <?&>
subtitle <?&>
title <&>
updated <&>
extension <*&>
entry <*&>
common
author =
define "author" $
elem "author" person
data Category
= Category
{ category_term :: TL.Text
, category_scheme :: Maybe URI
, category_label :: Maybe TL.Text
, category_extensions :: [Extension]
, category_common :: Common
} deriving (Show,Generic)
category =
define "category" $
elem "category" $
adt @Category $
permutable $
attr "term" text <&>
attr "scheme" uri <?&>
attr "label" text <?&>
extension <*&>
common
contributor =
define "contributor" $
elem "contributor" person
data Generator
= Generator
{ generator_uri :: Maybe URI
, generator_version :: Maybe TL.Text
, generator_common :: Common
, generator_text :: TL.Text
} deriving (Show,Generic)
generator =
define "generator" $
elem "generator" $
adt @Generator $
permutable $
attr "uri" uri <?&>
attr "version" text <?&>
common <:>
perm text
icon =
define "icon" $
elem "icon" $
permutable common <:>
uri
id =
define "id" $
elem "id" $
permutable common <:>
uri
data Link
= Link
{ link_href :: URI
, link_rel :: Maybe (Either RelName URI)
, link_type :: Maybe MediaType
, link_hreflang :: Maybe LanguageTag
, link_title :: Maybe TL.Text
, link_length :: Maybe TL.Text
, link_extension :: [Extension]
, link_common :: Common
} deriving (Show,Generic)
link =
define "link" $
elem "link" $
adt @Link $
permutable $
attr "href" uri <&>
attr "rel" (relName <+> uri) <?&>
attr "type" text <?&>
attr "hreflang" languageTag <?&>
attr "title" text <?&>
attr "length" text <?&>
extension <*&>
common
newtype RelName = RelName TL.Text
deriving (Eq,Show)
instance DecodeText RelName where
decodeText = RelName . fst <$> P.match (
P.some $
P.notFollowedBy (P.char ':' P.<|> P.spaceChar)
*> P.printChar)
instance RNCText RelName where
rncText_qname = QName xmlns_xsd "string"
rncText_params = Map.fromList
[ ("minLength", "1")
, ("pattern", "[^: ]*")
]
relName =
define "relName" $
text @_ @RelName
newtype MediaType = MediaType TL.Text
deriving (Eq,Show)
instance DecodeText MediaType where
decodeText = MediaType . fst <$> P.match (
P.some c *> P.char '/' *> P.some c)
where c = P.notFollowedBy (P.spaceChar <|> P.char '/') *> P.printChar
instance RNCText MediaType where
rncText_qname = QName xmlns_xsd "string"
rncText_params = Map.fromList
[ ("pattern", ".+/.+")
]
mediaType =
define "mediaType" $
text @_ @MediaType
logo =
define "logo" $
elem "logo" $
permutable common <:>
uri
rights = elem "rights" textConstruct
subtitle = elem "subtitle" textConstruct
title = elem "title" textConstruct
updated = elem "updated" dateConstruct
data Entry
= Entry
{ entry_authors :: [Person]
, entry_categories :: [Category]
, entry_content :: Maybe (Common, Content)
, entry_contributors :: [Person]
, entry_id :: (Common, URI)
, entry_links :: [Link]
, entry_published :: Maybe (Common, DateTime)
, entry_rights :: Maybe Text
, entry_source :: Maybe Source
, entry_summary :: Maybe Text
, entry_title :: Text
, entry_updated :: (Common, DateTime)
, entry_extensions :: [Extension]
, entry_common :: Common
} deriving (Show,Generic)
entry =
define "entry" $
elem "entry" $
adt @Entry $
permutable $
author <*&>
category <*&>
content <?&>
contributor <*&>
id <&>
link <*&>
published <?&>
rights <?&>
source <?&>
summary <?&>
title <&>
updated <&>
extension <*&>
common
data Content
= Content_Text TL.Text
| Content_Html TL.Text
| Content_Xhtml XHTML
| Content_Src (Maybe MediaType) URI
| Content_Any (Maybe MediaType) (Either TL.Text Any)
deriving (Show,Generic)
content =
define "content" $
elem "content" $
permutable common <:>
adt @Content (
(type_ "text" <.> text) <+>
(type_ "html" <.> text) <+>
(type_ "xhtml" <.> divXHTML) <+>
(optional mediaType <:> attr "src" uri <.> empty) <+>
(optional mediaType <:> (text <+> anyNode))
)
where type_ t = attr "type" (literal t)
published = elem "published" dateConstruct
summary = elem "summary" textConstruct
data Source
= Source
{ source_authors :: [Person]
, source_categories :: [Category]
, source_contributors :: [Person]
, source_generator :: Maybe Generator
, source_icon :: Maybe (Common, URI)
, source_id :: Maybe (Common, URI)
, source_links :: [Link]
, source_logo :: Maybe (Common, URI)
, source_rights :: Maybe Text
, source_subtitle :: Maybe Text
, source_title :: Maybe Text
, source_updated :: Maybe (Common, DateTime)
, source_extensions :: [Extension]
, source_common :: Common
} deriving (Show,Generic)
source =
define "source" $
elem "source" $
adt @Source $
permutable $
author <*&>
category <*&>
contributor <*&>
generator <?&>
icon <?&>
id <?&>
link <*&>
logo <?&>
rights <?&>
subtitle <?&>
title <?&>
updated <?&>
extension <*&>
common
type Extension = (QName, ([(QName, TL.Text)], Tree.Forest AnyNode))
extension =
define "extension" $
construct (,) $
elementMatch ((*:*) :-: (:*) xmlns_atom) $
many0 (construct (,) (attributeMatch (*:*) text))
<:>
many0 anyNode
type Any = Tree.Tree AnyNode
data AnyNode
= AnyNode_Elem QName [(QName, TL.Text)]
| AnyNode_Text TL.Text
deriving (Show,Generic)
anyNode =
define "anyNode" $
adt @(Tree.Tree AnyNode) $
dimap
(\case
Left (n,(as,ts)) -> (AnyNode_Elem n as, ts)
Right t -> (AnyNode_Text t, mempty)
)
(\case
(AnyNode_Elem n as, ts) -> Left (n,(as,ts))
(AnyNode_Text t, _) -> Right t
) $
construct (,) (elementMatch (*:*) (
many0 (construct (,) (attributeMatch (*:*) text))
<:>
many0 anyNode
))
<+> text
type XHTML = Tree.Tree XHTMLNode
data XHTMLNode
= XHTMLNode_Elem QName [(QName, TL.Text)]
| XHTMLNode_Text TL.Text
deriving (Show,Generic)
xhtmlNode =
define "xhtmlNode" $
adt @(Tree.Tree XHTMLNode) $
dimap
(\case
Left (n,(as,ts)) -> (XHTMLNode_Elem n as, ts)
Right t -> (XHTMLNode_Text t, mempty)
)
(\case
(XHTMLNode_Elem n as, ts) -> Left (n,(as,ts))
(XHTMLNode_Text t, _) -> Right t
) $
construct (,) (elementMatch ((:*) xmlns_xhtml) (
many0 (construct (,) (attributeMatch (*:*) text))
<:>
many0 xhtmlNode
))
<+> text
divXHTML =
define "divXHTML" $
let div = QName xmlns_xhtml "div" in
adt @(Tree.Tree XHTMLNode) $
dimap
(\case
(as,Left ts) -> (XHTMLNode_Elem div as, ts)
(_as,Right t) -> (XHTMLNode_Text t, mempty)
)
(\case
(XHTMLNode_Elem _n as, ts) -> (as,Left ts)
(XHTMLNode_Text t, _) -> (mempty,Right t)
) $
element div $
many0 (construct (,) (attributeMatch (*:*) text))
<:>
(many0 xhtmlNode <+> text)