{-# 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.Monoid (Monoid(..))
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)
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 'XmlPos'
data XmlPos
 =   XmlPos
 {   xmlPosAncestors          :: [(XmlName,Rank)]
 ,   xmlPosPrecedingsSiblings :: Map XmlName Rank
 } deriving (Eq,Ord,Show)
instance Default XmlPos where
	def = XmlPos mempty mempty

-- * Type 'Rank'
type Rank = Int

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Int }
 deriving (Eq, Ord, Show)

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)

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

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

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

-- * 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