{-# 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.Map.Strict (Map)
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.Lazy as TL

import Language.TCT.Cell
import Language.TCT.Debug

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

-- ** Type 'XmlName'
data XmlName
 =   XmlName
 {   xmlNamePrefix :: TL.Text
 ,   xmlNameSpace  :: TL.Text
 ,   xmlNameLocal  :: TL.Text
 }
instance Show XmlName where
	showsPrec _p XmlName{xmlNameSpace="", ..} =
		showString (TL.unpack xmlNameLocal)
	showsPrec _p XmlName{..} =
		if TL.null xmlNameSpace
		then showString (TL.unpack xmlNameLocal)
		else
			showChar '{' .
			showString (TL.unpack xmlNameSpace) .
			showChar '}' .
			showString (TL.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 "" (TL.pack ns) (TL.pack $ List.drop 1 local)
	fromString local = XmlName "" "" (TL.pack local)
instance Pretty XmlName

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

-- ** Type 'XmlNode'
data XmlNode
 =   XmlElem    XmlName
 |   XmlAttr    XmlName TL.Text
 |   XmlText    TL.Text
 |   XmlComment TL.Text
 deriving (Eq,Ord,Show)
instance Pretty XmlNode

-- ** Type 'XmlAttrs'
type XmlAttrs = Map XmlName (Cell TL.Text)

-- * Type 'Rank'
-- | nth child
type Rank = Int

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Int }
 deriving (Eq, Ord)
instance Show Nat where
	showsPrec p = showsPrec p . unNat
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)
instance Show Nat1 where
	showsPrec p = showsPrec p . unNat1
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 :: TL.Text }
 deriving (Eq,Ord,Show,Default,IsString)

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

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

-- * Type 'MayText'
newtype MayText
 =      MayText { unMayText :: TL.Text }
 deriving (Eq,Ord,Default)
instance Show MayText where
	showsPrec p = showsPrec p . unMayText
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

instance Default Text where
	def = ""
instance Default TL.Text where
	def = ""