{-# LANGUAGE DeriveDataTypeable #-}

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.DOM.QualifiedName
   Copyright  : Copyright (C) 2011 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   The types and functions for qualified names

-}

-- ------------------------------------------------------------

module Text.XML.HXT.DOM.QualifiedName
    ( QName
    , XName(unXN)
    , NsEnv

    , mkQName
    , mkName
    , mkNsName
    , mkSNsName
    , mkPrefixLocalPart

    , equivQName
    , equivUri
    , equalQNameBy

    , namePrefix
    , localPart
    , namespaceUri

    , newXName
    , nullXName
    , isNullXName
    , newQName

    , mkQName'
    , namePrefix'
    , localPart'
    , namespaceUri'

    , setNamePrefix'
    , setLocalPart'
    , setNamespaceUri'

    , qualifiedName
    , qualifiedName'
    , universalName
    , universalUri
    , buildUniversalName

    , normalizeNsUri

    , setNamespace                      -- namespace related functions
    , isNCName
    , isWellformedQualifiedName
    , isWellformedQName
    , isWellformedNSDecl
    , isWellformedNameSpaceName
    , isNameSpaceName
    , isDeclaredNamespace

    , xmlNamespaceXName
    , xmlXName
    , xmlnsNamespaceXName
    , xmlnsXName
    , xmlnsQN

    , toNsEnv
    )

where

{-
import           Debug.Trace
 -}

import           Control.Arrow                     ((***))

import           Control.DeepSeq
import           Control.FlatSeq

import           Data.AssocList
import           Data.Binary
import           Data.Char                         (toLower)
import           Data.IORef
import           Data.List                         (isPrefixOf)
import qualified Data.Map                          as M
import           Data.Typeable

import           System.IO.Unsafe                  (unsafePerformIO)

import           Text.XML.HXT.DOM.XmlKeywords      (a_xml, a_xmlns,
                                                    xmlNamespace,
                                                    xmlnsNamespace)

import           Data.Char.Properties.XMLCharProps (isXmlNCNameChar,
                                                    isXmlNCNameStartChar)

-- -----------------------------------------------------------------------------

-- | XML names are represented by Strings, but these strings do not mix up with normal strings.
-- Names are always reduced to normal form, and they are stored internally in a name cache
-- for sharing equal names by the same data structure

data XName                      = XN { _idXN :: ! Int        -- for optimization of equality test, see Eq instance
                                     ,  unXN ::   String
                                     }
                                  deriving (Typeable)

instance Eq XName where
    (XN id1 _) == (XN id2 _)    = id1 == id2

instance Ord XName where
    compare (XN _ n1) (XN _ n2) = compare n1 n2
{-
instance Read XName where
    readsPrec p str             = [ (newXName x, y) | (x, y) <- readsPrec p str ]

instance Show XName where
    show (XN _ s)               = show s
-}
instance NFData XName where
    rnf (XN _ s)                = rnf s

instance WNFData XName where
    rwnf (XN _ s)               = rnf s

instance Binary XName where
    put (XN _ s)                = put s
    get                         = do
                                  s <- get
                                  return $! newXName s

-----------------------------------------------------------------------------

-- |
-- Type for the namespace association list, used when propagating namespaces by
-- modifying the 'QName' values in a tree

type NsEnv              = AssocList XName XName

-----------------------------------------------------------------------------

-- |
-- Namespace support for element and attribute names.
--
-- A qualified name consists of a name prefix, a local name
-- and a namespace uri.
-- All modules, which are not namespace aware, use only the 'localPart' component.
-- When dealing with namespaces, the document tree must be processed by 'Text.XML.HXT.Arrow.Namespace.propagateNamespaces'
-- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri

data QName      = QN { localPart'    :: ! XName
                     , namePrefix'   :: ! XName
                     , namespaceUri' :: ! XName
                     }
             deriving (Typeable)

-- -----------------------------------------------------------------------------

-- | Two QNames are equal if (1. case) namespaces are both empty and the qualified names
-- (prefix:localpart) are the same or (2. case) namespaces are set and namespaces and
-- local parts are equal

instance Eq QName where
    (QN lp1 px1 ns1) == (QN lp2 px2 ns2)
        | ns1 /= ns2            = False                 -- namespaces are set and differ
        | not (isNullXName ns1) = lp1 == lp2            -- namespaces are set and are equal: local parts must be equal
        | otherwise             = lp1 == lp2            -- no namespaces are set: local parts must be equal
                                  &&                    -- and prefixes are not set or they are equal
                                  px1 == px2

instance Ord QName where
  compare (QN lp1 px1 ns1) (QN lp2 px2 ns2)
      | isNullXName ns1 && isNullXName ns2              -- no namespaces set: px is significant
          = compare (px1, lp1) (px2, lp2)
      | otherwise                                       -- namespace aware cmp: ns is significant, px is irrelevant
          = compare (lp1, ns1) (lp2, ns2)

instance NFData  QName where
    rnf x = seq x ()

instance WNFData QName

instance Show QName where
    show = showQN

-- -----------------------------------------------------------------------------

instance Binary QName where
    put (QN lp px ns)   = put (unXN px) >>
                          put (unXN lp) >>
                          put (unXN ns)
    get                 = do
                          px <- get
                          lp <- get
                          ns <- get
                          return $! newNsName lp px ns
                          --     ^^
                          -- strict apply !!!
                          -- build the QNames strict, else the name sharing optimization will not be in effect

-- -----------------------------------------------------------------------------

isNullXName             :: XName -> Bool
isNullXName             = (== nullXName)
{-# INLINE isNullXName #-}

namePrefix              :: QName -> String
namePrefix              = unXN . namePrefix'
{-# INLINE namePrefix #-}

localPart               :: QName -> String
localPart               = unXN . localPart'
{-# INLINE localPart #-}

namespaceUri            :: QName -> String
namespaceUri            = unXN . namespaceUri'
{-# INLINE namespaceUri #-}

-- ------------------------------------------------------------

-- | set name prefix

setNamespaceUri'                        :: XName -> QName -> QName
setNamespaceUri' ns (QN lp px _ns)      = newQName lp px ns

-- | set local part

setLocalPart'                           :: XName -> QName -> QName
setLocalPart' lp (QN _lp px ns)         = newQName lp px ns

-- | set name prefix

setNamePrefix'                          :: XName -> QName -> QName
setNamePrefix' px (QN lp _px ns)        = newQName lp px ns

-- ------------------------------------------------------------

-- |
-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result

qualifiedName                   :: QName -> String
qualifiedName (QN lp px _ns)
    | isNullXName px            = unXN lp
    | otherwise                 = unXN px ++ (':' : unXN lp)

-- | functional list version of qualifiedName used in xshow

qualifiedName'                   :: QName -> String -> String
qualifiedName' (QN lp px _ns)
    | isNullXName px            = (unXN lp ++)
    | otherwise                 = (unXN px ++) . (':' :) . (unXN lp ++)

-- |
-- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part
-- (specialisation of 'buildUniversalName')

universalName                   :: QName -> String
universalName                   = buildUniversalName (\ ns lp -> '{' : ns ++ '}' : lp)

-- |
-- builds an \"universal\" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,
-- where the subject, predicate and object often are concatenated from namespace uri and local part
-- (specialisation of 'buildUniversalName')

universalUri                    :: QName -> String
universalUri                    = buildUniversalName (++)

-- |
-- builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else
-- namespace uri and local part are combined with the combining function given by the first parameter

buildUniversalName              :: (String -> String -> String) -> QName -> String
buildUniversalName bf n@(QN _lp _px ns)
    | isNullXName ns            = localPart n
    | otherwise                 = unXN ns `bf` localPart n

showQN                          :: QName -> String
showQN n
    | null ns                   = show $ qualifiedName n
    | otherwise                 = show $ "{" ++ ns ++ "}" ++ qualifiedName n
    where
    ns = namespaceUri n

-- ------------------------------------------------------------
--
-- internal XName functions

mkQName'                        :: XName -> XName -> XName -> QName
mkQName' px lp ns               = newQName lp px ns
{-# DEPRECATED mkQName' "use newQName instead with lp px ns param seq " #-}

-- ------------------------------------------------------------

-- |
-- constructs a simple name, with prefix and localPart but without a namespace uri.
--
-- see also 'mkQName', 'mkName'

mkPrefixLocalPart               :: String -> String -> QName
mkPrefixLocalPart px lp
    | null px                   = newLpName lp
    | otherwise                 = newPxName lp px

-- |
-- constructs a simple, namespace unaware name.
-- If the name is in @prefix:localpart@ form and the prefix is not empty
-- the name is split internally into
-- a prefix and a local part.

mkName                          :: String -> QName
mkName n
    | (':' `elem` n)
      &&
      not (null px)                     -- more restrictive: isWellformedQualifiedName n
                                = newPxName lp px
    | otherwise                 = newLpName n
    where
    (px, (_ : lp)) = span (/= ':') n

-- |
-- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.
-- This function can be used to build not wellformed prefix:localpart names.
-- The XPath module uses wildcard names like @xxx:*@. These must be build with 'mkQName'
-- and not with mkName.

mkQName                         :: String -> String -> String -> QName
mkQName px lp ns
    | null ns                   = mkPrefixLocalPart px lp
    | otherwise                 = newNsName lp px ns

-- ------------------------------------------------------------

-- |
-- old name for 'mkName'

mkSNsName                       :: String -> QName
mkSNsName                       = mkName
{-# DEPRECATED mkSNsName "use mkName instead" #-}

-- |
-- constructs a simple, namespace aware name, with prefix:localPart as first parameter,
-- namspace uri as second.
--
-- see also 'mkName', 'mkPrefixLocalPart'

{-
mkNsName                          :: String -> String -> QName
mkNsName n ns                     = trace ("mkNsName: " ++ show n ++ " " ++ show ns) (mkNsName' n ns)
-}

mkNsName                          :: String -> String -> QName
mkNsName n ns
    | null ns                   = qn
    | otherwise                 = setNamespaceUri' ns' qn
    where
    qn                          = mkName n
    ns'                         = newXName ns

-- ------------------------------------------------------------

-- | Equivalent QNames are defined as follows: The URIs are normalized before comparison.
-- Comparison is done with 'equalQNameBy' and 'equivUri'

equivQName                      :: QName -> QName -> Bool
equivQName                      = equalQNameBy equivUri

-- | Comparison of normalized namespace URIs using 'normalizeNsUri'

equivUri                        :: String -> String -> Bool
equivUri x y                    = normalizeNsUri x == normalizeNsUri y

-- | Sometimes a weaker equality relation than 'equalQName' is appropriate, e.g no case significance in names, ...
-- a name normalization function can be applied to the strings before comparing. Called by 'equalQName' and
-- 'equivQName'

equalQNameBy                    :: (String -> String -> Bool) -> QName -> QName -> Bool
equalQNameBy equiv q1 q2        = localPart q1 == localPart q2
                                  &&
                                  (namespaceUri q1 `equiv` namespaceUri q2)

-- |  Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing \"\/\" is ignored

normalizeNsUri                  :: String -> String
normalizeNsUri                  = map toLower . stripSlash
    where
    stripSlash ""               = ""
    stripSlash s
        | last s == '/'         = init s
        | otherwise             = s

-- -----------------------------------------------------------------------------

-- Namespace predicates

-- |
-- Compute the name prefix and the namespace uri for a qualified name.
--
-- This function does not test whether the name is a wellformed qualified name.
-- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,
-- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.

setNamespace                    :: NsEnv -> QName -> QName
setNamespace env n@(QN lp px _ns)
                                = maybe n (\ ns -> newQName lp px ns) . lookup px $ env

-- -----------------------------------------------------------------------------
--

-- |
-- test for wellformed NCName, rule [4] XML Namespaces

isNCName                        :: String -> Bool
isNCName []                     = False
isNCName n                      = and ( zipWith ($)
                                        (isXmlNCNameStartChar : repeat isXmlNCNameChar)
                                        n
                                      )

-- |
-- test for wellformed QName, rule [6] XML Namespaces
-- predicate is used in filter 'valdateNamespaces'.

isWellformedQualifiedName       :: String -> Bool
isWellformedQualifiedName s
    | null lp                   = isNCName px
    | otherwise                 = isNCName px && isNCName (tail lp)
    where
    (px, lp)                    = span (/= ':') s

-- |
-- test for wellformed QName values.
-- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.
-- predicate is used in filter 'valdateNamespaces'.

isWellformedQName               :: QName -> Bool
isWellformedQName (QN lp px _ns)
                                = (isNCName . unXN) lp                          -- rule [8] XML Namespaces
                                  &&
                                  ( isNullXName px
                                    ||
                                    (isNCName . unXN) px                        -- rule [7] XML Namespaces
                                  )

-- |
-- test whether an attribute name is a namesapce declaration name.
-- If this is not the case True is the result, else
-- the name must be a well formed namespace name:
-- All namespace prefixes starting with \"xml\" are reserved for XML related definitions.
-- predicate is used in filter 'valdateNamespaces'.

isWellformedNSDecl              :: QName -> Bool
isWellformedNSDecl n
                                = not (isNameSpaceName n)
                                  ||
                                  isWellformedNameSpaceName n

-- |
-- test for a namespace name to be well formed

isWellformedNameSpaceName       :: QName -> Bool
isWellformedNameSpaceName n@(QN lp px _ns)
    | isNullXName px            = lp == xmlnsXName
    | otherwise                 = px == xmlnsXName
                                  &&
                                  not (null lp')
                                  &&
                                  not (a_xml `isPrefixOf` lp')
    where
    lp'                         = localPart n


-- |
-- test whether a name is a namespace declaration attribute name

isNameSpaceName                         :: QName -> Bool
isNameSpaceName (QN lp px _ns)
    | isNullXName px                    = lp == xmlnsXName
    | otherwise                         = px == xmlnsXName

-- |
--
-- predicate is used in filter 'valdateNamespaces'.

isDeclaredNamespace                     :: QName -> Bool
isDeclaredNamespace (QN _lp px ns)
    | isNullXName px                    = True                          -- no namespace used
    | px == xmlnsXName                  = ns == xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri
    | px == xmlXName                    = ns == xmlNamespaceXName       -- "xml" has a predefiend namespace"
    | otherwise                         = not (isNullXName ns)          -- namespace values are not empty

-- -----------------------------------------------------------------------------

toNsEnv                         :: AssocList String String -> NsEnv
toNsEnv                         = map (newXName *** newXName)

-- -----------------------------------------------------------------------------

-- the name and string cache

data NameCache          = NC { _newXN   :: ! Int                                       -- next free name id
                             , _xnCache :: ! (M.Map String XName)
                             , _qnCache :: ! (M.Map (XName, XName, XName) QName)       -- we need another type than QName
                             }                                                          -- for the key because of the unusable
                                                                                        -- Eq instance of QName
type ChangeNameCache r  = NameCache -> (NameCache, r)

-- ------------------------------------------------------------

-- | the internal cache for QNames (and name strings)

theNameCache            :: IORef NameCache
theNameCache            = unsafePerformIO (newIORef $ initialCache)
{-# NOINLINE theNameCache #-}

initialXNames           :: [XName]

nullXName
 , xmlnsNamespaceXName
 , xmlnsXName
 , xmlNamespaceXName
 , xmlXName             :: XName

initialXNames@
 [ nullXName
 , xmlnsNamespaceXName
 , xmlnsXName
 , xmlNamespaceXName
 , xmlXName
 ]                      = zipWith XN [0..] $
                          [ ""
                          , xmlnsNamespace
                          , a_xmlns
                          , xmlNamespace
                          , a_xml
                          ]

initialQNames           :: [QName]

xmlnsQN                 :: QName

initialQNames@
 [xmlnsQN]              = [QN xmlnsXName nullXName xmlnsNamespaceXName]

initialCache            :: NameCache
initialCache            = NC
                          (length initialXNames)
                          (M.fromList $ map (\ xn -> (unXN xn, xn)) initialXNames)
                          (M.fromList $ map (\ qn@(QN lp px ns) -> ((lp, px, ns), qn)) initialQNames)

-- ------------------------------------------------------------

changeNameCache         :: NFData r => ChangeNameCache r -> r
changeNameCache action  = unsafePerformIO changeNameCache'
    where
    action' c =
      let r = action c
      in
       fst r `seq` r    -- eval name cache to whnf

    changeNameCache' =
      do
      -- putStrLn "modify cache"
      res <- atomicModifyIORef theNameCache action'
      -- putStrLn "cache modified"
      return res

{-# NOINLINE changeNameCache #-}

newXName'               :: String -> ChangeNameCache XName
newXName' n c@(NC nxn xm qm)
                        = case M.lookup n xm of
                          Just xn       -> (c, xn)
                          Nothing       -> let nxn' = nxn + 1 in
                                           let xn   = (XN nxn n) in
                                           let xm'  = M.insert n xn xm in
                                           -- trace ("newXName: XN " ++ show nxn ++ " " ++ show n) $
                                           rnf xn `seq` (NC nxn' xm' qm, xn)

newQName'               :: XName -> XName -> XName -> ChangeNameCache QName
newQName' lp px ns c@(NC nxn xm qm)
                        = case M.lookup q' qm of
                          Just qn       -> -- trace ("oldQName: " ++ show qn) $                 -- log evaluation sequence
                                           (c, qn)
                          Nothing       -> let qm'  = M.insert q' q qm in
                                           -- trace ("newQName: " ++ show q) $                  -- log insertion of a new QName
                                           q `seq` (NC nxn xm qm', q)
    where
    q'                  = (lp, px, ns)
    q                   = QN lp px ns

andThen                 :: ChangeNameCache r1 ->
                           (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
andThen a1 a2 c0        = let (c1, r1) = a1 c0 in
                          (a2 r1) c1

newXName                :: String -> XName
newXName n              = changeNameCache $
                          newXName' n

newQName                :: XName -> XName -> XName -> QName
newQName lp px ns       = lp `seq` px `seq` ns `seq`            -- XNames must be evaluated, else MVar blocks
                          ( changeNameCache $
                            newQName' lp px ns
                          )

newLpName               :: String -> QName
newLpName lp            = changeNameCache $
                          newXName' lp `andThen` \ lp' ->
                          newQName' lp' nullXName nullXName

newPxName               :: String -> String -> QName
newPxName lp px         = changeNameCache $
                          newXName' lp `andThen` \ lp' ->
                          newXName' px `andThen` \ px' ->
                          newQName' lp' px' nullXName

newNsName               :: String -> String -> String -> QName
newNsName lp px ns      = changeNameCache $
                          newXName' lp `andThen` \ lp' ->
                          newXName' px `andThen` \ px' ->
                          newXName' ns `andThen` \ ns' ->
                          newQName' lp' px' ns'

-----------------------------------------------------------------------------