{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.XML where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree)
import Prelude (error, pred, succ)
import Text.Show (Show(..), showsPrec, showChar, showString)
import qualified Data.List as List
import qualified Data.Text as Text

import Language.TCT.Cell

-- * Type 'XML'
type XML  = Tree (Cell XmlName) (Cell XmlLeaf)
type XMLs = Seq XML

-- ** Type 'XmlName'
data XmlName
 =   XmlName
 {   xmlNamePrefix :: Text
 ,   xmlNameSpace  :: Text
 ,   xmlNameLocal  :: Text
 }
instance Show XmlName where
	showsPrec _p XmlName{xmlNameSpace="", ..} =
		showString (Text.unpack xmlNameLocal)
	showsPrec _p XmlName{..} =
		if Text.null xmlNameSpace
		then showString (Text.unpack xmlNameLocal)
		else
			showChar '{' .
			showString (Text.unpack xmlNameSpace) .
			showChar '}' .
			showString (Text.unpack xmlNameLocal)
instance Eq XmlName where
	XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
instance Ord XmlName where
	XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
instance IsString XmlName where
	fromString "" = XmlName "" "" ""
	fromString full@('{':rest) =
		case List.break (== '}') rest of
		 (_, "")     -> error ("Invalid Clark notation: " <> show full)
		 (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local)
	fromString local = XmlName "" "" (Text.pack local)

xmlLocalName :: Text -> XmlName
xmlLocalName = XmlName "" ""

-- ** Type 'XmlLeaf'
data XmlLeaf
 =   XmlAttr    XmlName Text
 |   XmlComment Text
 |   XmlText    Text
 deriving (Eq,Ord,Show)

-- * Type 'Rank'
type Rank = Int

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Int }
 deriving (Eq, Ord, Show)
instance Default Nat where
	def = Nat 0

succNat :: Nat -> Nat
succNat (Nat n) = Nat $ succ n

predNat :: Nat -> Maybe Nat
predNat (Nat n) | n <= 0    = Nothing
                | otherwise = Just $ Nat $ pred n

-- * Type 'Nat1'
newtype Nat1 = Nat1 { unNat1 :: Int }
 deriving (Eq, Ord, Show)
instance Default Nat1 where
	def = Nat1 1

succNat1 :: Nat1 -> Nat1
succNat1 (Nat1 n) = Nat1 $ succ n
predNat1 :: Nat1 -> Maybe Nat1
predNat1 (Nat1 n) | n <= 1    = Nothing
                  | otherwise = Just $ Nat1 $ pred n

-- * Type 'Ident'
newtype Ident = Ident { unIdent :: Text }
 deriving (Eq,Ord,Show,Default,IsString)
instance Default Text where
	def = ""

-- * Type 'URL'
newtype URL = URL { unURL :: Text }
 deriving (Eq,Ord,Show,Default)
instance Semigroup URL where
	_x <> y = y

-- * Type 'Path'
newtype Path = Path Text
 deriving (Eq,Show,Default)

-- * Type 'MayText'
newtype MayText
 =      MayText { unMayText :: Text }
 deriving (Eq,Show,Default)
instance Semigroup MayText where
	MayText "" <> y = y
	x <> MayText "" = x
	_x <> y          = y

whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
whenMayText (MayText "") _f = pure ()
whenMayText t f = f t