{-# 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

-- | Main symantic to be used.
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
  -- | Unconstrained; it's not entirely clear how IRI fit into
  -- @xsd:anyURI@ so let's not try to constrain it here.
  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 <+> -- xhtmlDiv
    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)