{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Symantic.XML.Document
 ( module Language.Symantic.XML.Document
 , TS.Tree(..)
 , TS.Trees
 ) where

import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), all)
import Data.Function (($), (.), id)
import Data.Hashable (Hashable(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import GHC.Generics (Generic)
import Prelude (error)
import Text.Show (Show(..), showsPrec, showChar, showString)
import qualified Data.Char.Properties.XMLCharProps as XC
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import qualified Data.Sequence as Seq

pattern Tree0 :: a -> TS.Tree a
pattern Tree0 a <- TS.Tree a (null -> True)
	where Tree0 a = TS.Tree a Seq.empty

-- ** Type 'Node'
data Node
 =   NodeElem    !QName          -- ^ Node with some 'NodeAttr' and then other 'Node's as children.
 |   NodeAttr    !QName          -- ^ Node with a 'NodeText' child.
 |   NodePI      !PName !TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodeAttr's.
 |   NodeText    !Text           -- ^ Leaf.
 |   NodeComment !TL.Text        -- ^ Leaf.
 |   NodeCDATA   !TL.Text        -- ^ Leaf.
 deriving (Eq,Ord,Show)

-- ** Type 'Text'
type Text = TL.Text

-- ** Type 'Name'
newtype Name = Name { unName :: TL.Text }
 deriving (Eq,Ord,Hashable)
instance Show Name where
	showsPrec _p = showString . TL.unpack . unName
instance IsString Name where
	fromString s
	 | c:cs <- s
	 , XC.isXmlNameStartChar c
	 && all XC.isXmlNameChar cs
	 = Name (TL.pack s)
	 | otherwise = error "Invalid XML Name"

-- ** Type 'NCName'
-- | Non-colonized name.
newtype NCName = NCName { unNCName :: TL.Text }
 deriving (Eq,Ord,Hashable)
instance Show NCName where
	showsPrec _p = showString . TL.unpack . unNCName
instance IsString NCName where
	fromString s
	 | c:cs <- s
	 , XC.isXmlNCNameStartChar c
	 && all XC.isXmlNCNameChar cs
	 = NCName (TL.pack s)
	 | otherwise = error "Invalid XML NCName"

-- ** Type 'PName'
-- | Prefixed name.
data PName = PName
 { pNameSpace :: !(Maybe NCName) -- ^ eg. Just "xml"
 , pNameLocal :: !NCName         -- ^ eg. "stylesheet"
 } deriving (Eq,Ord,Generic)
instance Show PName where
	showsPrec p PName{pNameSpace=Nothing, ..} =
		showsPrec p pNameLocal
	showsPrec _p PName{pNameSpace=Just p, ..} =
		showsPrec 10 p .
		showChar ':' .
		showsPrec 10 pNameLocal
instance IsString PName where
	fromString "" = PName Nothing "" -- NOTE: NCName's fromString will raise an error.
	fromString s =
		case List.break (== ':') s of
		 (_, "")    -> PName Nothing $ fromString s
		 (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)
instance Hashable PName

pName :: NCName -> PName
pName = PName Nothing
{-# INLINE pName #-}

-- ** Type 'QName'
-- | Qualified name.
data QName = QName
 { qNameSpace :: !Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
 , qNameLocal :: !NCName    -- ^ eg. "stylesheet"
 } deriving (Eq,Ord,Generic)
instance Show QName where
	showsPrec _p QName{..} =
		(if TL.null $ unNamespace qNameSpace then id
		else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'
		) . showsPrec 10 qNameLocal
instance IsString QName where
	fromString "" = QName "" "" -- NOTE: NCName's fromString will raise an error.
	fromString full@('{':rest) =
		case List.break (== '}') rest of
		 (_, "")     -> error ("Invalid XML Clark notation: " <> show full)
		 (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local
	fromString local = QName "" $ fromString local
instance Hashable QName

qName :: NCName -> QName
qName = QName ""
{-# INLINE qName #-}

-- *** Type 'Namespace'
newtype Namespace = Namespace { unNamespace :: TL.Text }
 deriving (Eq,Ord,Show,Hashable)
instance IsString Namespace where
	fromString s =
		if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s
		then Namespace (fromString s)
		else error $ "Invalid XML Namespace: " <> show s

xmlns_xml, xmlns_xmlns :: Namespace
xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"
xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"