{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.XML.Namespace where

import Control.Applicative (Alternative(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (all)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Hashable (Hashable(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import GHC.Generics (Generic)
import Prelude (error)
import Text.Show (Show(..), showsPrec, showChar, showString)
import qualified Data.Char.Properties.XMLCharProps as XC
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Text.Lazy as TL

-- * Type 'QName'
-- | Qualified name.
data QName
 =   QName
 {   qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
 ,   qNameLocal :: NCName    -- ^ eg. "stylesheet"
 } deriving (Eq, Ord, Generic)
instance Show QName where
  showsPrec _p QName{..} =
    (if TL.null $ unNamespace qNameSpace then id
    else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'
    ) . showsPrec 10 qNameLocal
instance IsString QName where
  -- NCName's fromString will raise an error.
  fromString "" = QName "" ""
  fromString full@('{':rest) =
    case List.break (== '}') rest of
     (_, "")     -> error $ "Invalid XML Clark notation: "<>show full
     (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local
  fromString local = QName "" $ fromString local
instance Hashable QName

qName :: NCName -> QName
qName = QName (Namespace "")
{-# INLINE qName #-}

-- ** Type 'Namespace'
newtype Namespace = Namespace { unNamespace :: TL.Text }
 deriving (Eq, Ord, Show, Hashable)
instance IsString Namespace where
  fromString s =
    if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s
    then Namespace (fromString s)
    else error $ "Invalid XML Namespace: "<>show s

xmlns_xml, xmlns_xmlns, xmlns_xsd, xmlns_empty :: Namespace
xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"
xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"
xmlns_xsd   = Namespace "http://www/w3/org/2001/XMLSchema-datatypes"
xmlns_empty = Namespace ""

-- *** Type 'Namespaces'
data Namespaces prefix
 =   Namespaces
 {   namespaces_prefixes :: HM.HashMap Namespace prefix
 ,   namespaces_default  :: Namespace
 } deriving (Show)
instance Functor Namespaces where
  fmap f (Namespaces ps d) = Namespaces (fmap f ps) d
instance Semigroup (Namespaces NCName) where
  x <> y = Namespaces
   { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y
   , namespaces_default  = namespaces_default x
   }
instance Semigroup (Namespaces (Maybe NCName)) where
  x <> y = Namespaces
   { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y)
   , namespaces_default  = namespaces_default x
   }
instance Monoid (Namespaces NCName) where
  mempty  = Namespaces HM.empty xmlns_empty
  mappend = (<>)
instance Monoid (Namespaces (Maybe NCName)) where
  mempty  = Namespaces HM.empty xmlns_empty
  mappend = (<>)

defaultNamespaces :: IsString prefix => Namespaces prefix
defaultNamespaces = Namespaces
 { namespaces_prefixes = HM.fromList
   [ (xmlns_xml  , "xml")
   , (xmlns_xmlns, "xmlns")
   ]
 , namespaces_default = xmlns_empty
 }

prefixifyQName :: Namespaces NCName -> QName -> PName
prefixifyQName Namespaces{..} QName{..} = PName
 { pNameSpace =
  if qNameSpace == namespaces_default
  then Nothing
  else HM.lookup qNameSpace namespaces_prefixes
 , pNameLocal = qNameLocal
 }

-- ** Type 'PName'
-- | Prefixed 'NCName'
data PName
 =   PName
 {   pNameSpace :: Maybe NCName -- ^ eg. Just "xml"
 ,   pNameLocal :: NCName       -- ^ eg. "stylesheet"
 } deriving (Eq, Ord, Generic)
instance Show PName where
  showsPrec p PName{pNameSpace=Nothing, ..} =
    showsPrec p pNameLocal
  showsPrec _p PName{pNameSpace=Just p, ..} =
    showsPrec 10 p .
    showChar ':' .
    showsPrec 10 pNameLocal
instance IsString PName where
  fromString "" = PName Nothing "" -- NCName's fromString will raise an error.
  fromString s =
    case List.break (== ':') s of
     (_, "")    -> PName Nothing $ fromString s
     (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)

pName :: NCName -> PName
pName = PName Nothing
{-# INLINE pName #-}

-- ** Type 'NCName'
-- | Non-colonized name.
newtype NCName = NCName { unNCName :: TL.Text }
 deriving (Eq, Ord, Hashable)
instance Show NCName where
  showsPrec _p = showString . TL.unpack . unNCName
instance IsString NCName where
  fromString s =
    fromMaybe (error $ "Invalid XML NCName: "<>show s) $
    ncName (TL.pack s)

ncName :: TL.Text -> Maybe NCName
ncName t =
  case TL.uncons t of
   Just (c, cs)
    | XC.isXmlNCNameStartChar c
    , TL.all XC.isXmlNCNameChar cs
    -> Just (NCName t)
   _ -> Nothing

poolNCNames :: [NCName]
poolNCNames =
  [ NCName $ TL.pack ("ns"<>show i)
  | i <- [1 :: Int ..]
  ]

freshNCName :: HS.HashSet NCName -> NCName
freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps

freshifyNCName :: HS.HashSet NCName -> NCName -> NCName
freshifyNCName ns (NCName n) =
  let ints = [1..] :: [Int] in
  List.head
   [ fresh
   | suffix <- mempty : (show <$> ints)
   , fresh <- [ NCName $ n <> TL.pack suffix]
   , not $ fresh `HS.member` ns
   ]