{-# 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
data QName
= QName
{ qNameSpace :: Namespace
, qNameLocal :: NCName
} 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
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 #-}
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 ""
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
}
data PName
= PName
{ pNameSpace :: Maybe NCName
, pNameLocal :: NCName
} 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 ""
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 #-}
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
]