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

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), on)
import Data.Int (Int)
import Data.Hashable (Hashable(..))
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, succ)
import Text.Show (Show(..), showsPrec, showChar, showString)
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL

import Hdoc.TCT.Cell
import Hdoc.TCT.Debug
import Hdoc.Utils ()

-- * 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
instance Hashable XmlName where
	hashWithSalt s XmlName{..} =
		s`hashWithSalt`xmlNamePrefix
		 `hashWithSalt`xmlNameSpace
		 `hashWithSalt`xmlNameLocal

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) -- TODO: HashMap

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

-- * Type 'XmlPos'
data XmlPos = XmlPos
 { xmlPos_Ancestors                :: XmlPosPath
 , xmlPos_AncestorsWithFigureNames :: XmlPosPath
 , xmlPos_PrecedingSiblings        :: Map XmlName Rank -- TODO: HashMap
 } deriving (Eq,Show)
instance Ord XmlPos where
	compare = compare`on`xmlPos_Ancestors
-- | Return only the hash on 'xmlPos_Ancestors',
-- which is unique because 'XmlPosPath'
-- includes the 'Rank' of each 'XmlNode'.
instance Hashable XmlPos where
	hashWithSalt s XmlPos{..} =
		s`hashWithSalt`xmlPos_Ancestors
instance Default XmlPos where
	def = XmlPos mempty mempty mempty

-- ** Type 'XmlPosPath'
type XmlPosPath = Seq (XmlName,Rank)

-- | Drop self.
dropSelfPosPath :: XmlPosPath -> Maybe XmlPosPath
dropSelfPosPath p =
	case Seq.viewr p of
	 Seq.EmptyR -> Nothing
	 ls Seq.:> _ -> Just ls

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Int }
 deriving (Eq,Ord,Hashable)
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,Hashable)
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,Semigroup,Monoid,Hashable)

-- * Type 'URL'
newtype URL = URL { unURL :: TL.Text }
 deriving (Eq,Ord,Default,Hashable)
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 = ""