src/Symantic/XML/Namespace.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE PatternSynonyms #-}
   6 {-# LANGUAGE StrictData #-}
   7 {-# LANGUAGE TypeFamilyDependencies #-}
   8 {-# LANGUAGE UndecidableInstances #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Symantic.XML.Namespace where
  11
  12 import Control.Applicative (Alternative(..))
  13 import Data.Bool
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (all)
  16 import Data.Function (($), (.), id)
  17 import Data.Functor (Functor(..), (<$>))
  18 import Data.Hashable (Hashable(..))
  19 import Data.Int (Int)
  20 import Data.Maybe (Maybe(..), fromMaybe)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Ord (Ord(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.String (String, IsString(..))
  25 import GHC.Generics (Generic)
  26 import Prelude (error)
  27 import Text.Show (Show(..), showsPrec, showChar, showString)
  28 import qualified Data.Char.Properties.XMLCharProps as XC
  29 import qualified Data.HashMap.Strict as HM
  30 import qualified Data.HashSet as HS
  31 import qualified Data.List as List
  32 import qualified Data.Text.Lazy as TL
  33
  34 -- * Type 'QName'
  35 -- | Qualified name.
  36 data QName
  37  =   QName
  38  {   qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
  39  ,   qNameLocal :: NCName    -- ^ eg. "stylesheet"
  40  } deriving (Eq, Ord, Generic)
  41 instance Show QName where
  42   showsPrec _p QName{..} =
  43     (if TL.null $ unNamespace qNameSpace then id
  44     else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'
  45     ) . showsPrec 10 qNameLocal
  46 instance IsString QName where
  47   -- NCName's fromString will raise an error.
  48   fromString "" = QName "" ""
  49   fromString full@('{':rest) =
  50     case List.break (== '}') rest of
  51      (_, "")     -> error $ "Invalid XML Clark notation: "<>show full
  52      (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local
  53   fromString local = QName "" $ fromString local
  54 instance Hashable QName
  55
  56 qName :: NCName -> QName
  57 qName = QName (Namespace "")
  58 {-# INLINE qName #-}
  59
  60 -- ** Type 'Namespace'
  61 newtype Namespace = Namespace { unNamespace :: TL.Text }
  62  deriving (Eq, Ord, Show, Hashable)
  63 instance IsString Namespace where
  64   fromString s =
  65     if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s
  66     then Namespace (fromString s)
  67     else error $ "Invalid XML Namespace: "<>show s
  68
  69 xmlns_xml, xmlns_xmlns, xmlns_xsd, xmlns_empty :: Namespace
  70 xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"
  71 xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"
  72 xmlns_xsd   = Namespace "http://www/w3/org/2001/XMLSchema-datatypes"
  73 xmlns_empty = Namespace ""
  74
  75 -- *** Type 'Namespaces'
  76 data Namespaces prefix
  77  =   Namespaces
  78  {   namespaces_prefixes :: HM.HashMap Namespace prefix
  79  ,   namespaces_default  :: Namespace
  80  } deriving (Show)
  81 instance Functor Namespaces where
  82   fmap f (Namespaces ps d) = Namespaces (fmap f ps) d
  83 instance Semigroup (Namespaces NCName) where
  84   x <> y = Namespaces
  85    { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y
  86    , namespaces_default  = namespaces_default x
  87    }
  88 instance Semigroup (Namespaces (Maybe NCName)) where
  89   x <> y = Namespaces
  90    { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y)
  91    , namespaces_default  = namespaces_default x
  92    }
  93 instance Monoid (Namespaces NCName) where
  94   mempty  = Namespaces HM.empty xmlns_empty
  95   mappend = (<>)
  96 instance Monoid (Namespaces (Maybe NCName)) where
  97   mempty  = Namespaces HM.empty xmlns_empty
  98   mappend = (<>)
  99
 100 defaultNamespaces :: IsString prefix => Namespaces prefix
 101 defaultNamespaces = Namespaces
 102  { namespaces_prefixes = HM.fromList
 103    [ (xmlns_xml  , "xml")
 104    , (xmlns_xmlns, "xmlns")
 105    ]
 106  , namespaces_default = xmlns_empty
 107  }
 108
 109 prefixifyQName :: Namespaces NCName -> QName -> PName
 110 prefixifyQName Namespaces{..} QName{..} = PName
 111  { pNameSpace =
 112   if qNameSpace == namespaces_default
 113   then Nothing
 114   else HM.lookup qNameSpace namespaces_prefixes
 115  , pNameLocal = qNameLocal
 116  }
 117
 118 -- ** Type 'PName'
 119 -- | Prefixed 'NCName'
 120 data PName
 121  =   PName
 122  {   pNameSpace :: Maybe NCName -- ^ eg. Just "xml"
 123  ,   pNameLocal :: NCName       -- ^ eg. "stylesheet"
 124  } deriving (Eq, Ord, Generic)
 125 instance Show PName where
 126   showsPrec p PName{pNameSpace=Nothing, ..} =
 127     showsPrec p pNameLocal
 128   showsPrec _p PName{pNameSpace=Just p, ..} =
 129     showsPrec 10 p .
 130     showChar ':' .
 131     showsPrec 10 pNameLocal
 132 instance IsString PName where
 133   fromString "" = PName Nothing "" -- NCName's fromString will raise an error.
 134   fromString s =
 135     case List.break (== ':') s of
 136      (_, "")    -> PName Nothing $ fromString s
 137      (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)
 138
 139 pName :: NCName -> PName
 140 pName = PName Nothing
 141 {-# INLINE pName #-}
 142
 143 -- ** Type 'NCName'
 144 -- | Non-colonized name.
 145 newtype NCName = NCName { unNCName :: TL.Text }
 146  deriving (Eq, Ord, Hashable)
 147 instance Show NCName where
 148   showsPrec _p = showString . TL.unpack . unNCName
 149 instance IsString NCName where
 150   fromString s =
 151     fromMaybe (error $ "Invalid XML NCName: "<>show s) $
 152     ncName (TL.pack s)
 153
 154 ncName :: TL.Text -> Maybe NCName
 155 ncName t =
 156   case TL.uncons t of
 157    Just (c, cs)
 158     | XC.isXmlNCNameStartChar c
 159     , TL.all XC.isXmlNCNameChar cs
 160     -> Just (NCName t)
 161    _ -> Nothing
 162
 163 poolNCNames :: [NCName]
 164 poolNCNames =
 165   [ NCName $ TL.pack ("ns"<>show i)
 166   | i <- [1 :: Int ..]
 167   ]
 168
 169 freshNCName :: HS.HashSet NCName -> NCName
 170 freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps
 171
 172 freshifyNCName :: HS.HashSet NCName -> NCName -> NCName
 173 freshifyNCName ns (NCName n) =
 174   let ints = [1..] :: [Int] in
 175   List.head
 176    [ fresh
 177    | suffix <- mempty : (show <$> ints)
 178    , fresh <- [ NCName $ n <> TL.pack suffix]
 179    , not $ fresh `HS.member` ns
 180    ]