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

import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), on)
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.TreeSeq.Strict (Tree)
import Prelude (error)
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 qualified Hdoc.TCT.Cell as TCT
import Hdoc.TCT.Debug
import Hdoc.Utils (Nat1)

-- * Type 'XML'
type XML  = Tree (TCT.Cell Node)
type XMLs = Seq XML

-- ** Type 'Name'
data Name = Name
 { namePrefix :: TL.Text -- ^ eg. "xsl"
 , nameSpace  :: TL.Text -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
 , nameLocal  :: TL.Text -- ^ eg. "stylesheet"
 }
instance Show Name where
	showsPrec _p Name{nameSpace="", ..} =
		showString (TL.unpack nameLocal)
	showsPrec _p Name{..} =
		if TL.null nameSpace
		then showString (TL.unpack nameLocal)
		else
			showChar '{' .
			showString (TL.unpack nameSpace) .
			showChar '}' .
			showString (TL.unpack nameLocal)
instance Eq Name where
	Name _ sx lx == Name _ sy ly = sx == sy && lx == ly
instance Ord Name where
	Name _ sx lx `compare` Name _ sy ly = compare sx sy <> compare lx ly
instance IsString Name where
	fromString "" = Name "" "" ""
	fromString full@('{':rest) =
		case List.break (== '}') rest of
		 (_, "")     -> error ("Invalid Clark notation: " <> show full)
		 (ns, local) -> Name "" (TL.pack ns) (TL.pack $ List.drop 1 local)
	fromString local = Name "" "" (TL.pack local)
instance Pretty Name
instance Hashable Name where
	hashWithSalt s Name{..} =
		s`hashWithSalt`namePrefix
		 `hashWithSalt`nameSpace
		 `hashWithSalt`nameLocal

localName :: TL.Text -> Name
localName = Name "" ""

-- ** Type 'Node'
data Node
 =   NodeElem    Name
 |   NodeAttr    Name TL.Text
 |   NodeText    TL.Text
 |   NodeComment TL.Text
 deriving (Eq,Ord,Show)
instance Pretty Node

-- ** Type 'Attrs'
type Attrs = Map Name (TCT.Cell TL.Text)

-- * Type 'Pos'
data Pos = Pos
 { pos_ancestors                :: Ancestors
 , pos_ancestorsWithFigureNames :: Ancestors
 , pos_precedingSiblings        :: Map Name Rank
 } deriving (Eq,Show)
instance Ord Pos where
	compare = compare`on`pos_ancestors
-- | Return only the hash on 'pos_ancestors',
-- which is unique because 'Ancestors'
-- includes the 'Rank' of each 'Node'.
instance Hashable Pos where
	hashWithSalt s Pos{..} =
		s`hashWithSalt`pos_ancestors
instance Default Pos where
	def = Pos mempty mempty mempty

-- ** Type 'Rank'
-- | Nth child.
type Rank = Nat1

-- ** Type 'Ancestors'
type Ancestors = Seq (Name, Rank)

ancestors :: Ancestors -> Maybe Ancestors
ancestors p =
	case Seq.viewr p of
	 Seq.EmptyR -> Nothing
	 ls Seq.:> _ -> Just ls

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