Language/Symantic/RNC/Write/Namespaces.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Language.Symantic.RNC.Write.Namespaces where
   4
   5 import Control.Applicative (Applicative(..), Alternative(..), (<$>))
   6 import Control.Monad (Monad(..), forM, sequence)
   7 import Data.Bool
   8 import Data.Default.Class (Default(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.), id)
  11 import Data.Functor (Functor(..))
  12 import Data.Int (Int)
  13 import Data.Maybe (Maybe(..), maybe, isNothing)
  14 import Data.Monoid (Monoid(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Text.Show (Show(..))
  17 import Data.String (String)
  18 import qualified Data.HashMap.Strict as HM
  19 import qualified Data.HashSet as HS
  20 import qualified Data.List as List
  21 import qualified Data.Text.Lazy as TL
  22 import qualified Control.Monad.Trans.State.Strict as S
  23
  24 import qualified Language.Symantic.XML as XML
  25 import Language.Symantic.RNC.Sym
  26
  27 -- | Collect 'XML.Namespace's used and get them a dedicated prefix.
  28 runNS :: forall a. [NS a] -> Namespaces XML.NCName
  29 runNS ns =
  30         namespaces
  31          { namespaces_prefixes =
  32                 (`S.evalState` HS.empty) $
  33                         let prefixesByNamespace =
  34                                 HM.delete "" $ -- NOTE: no prefix when there is no namespace.
  35                                 HM.update -- NOTE: no prefix when this is the default namespace.
  36                                  (\p -> if isNothing p then Nothing else Just p)
  37                                  (namespaces_default namespaces) $
  38                                 namespaces_prefixes namespaces in
  39                         forM prefixesByNamespace $ \mp -> do
  40                                 usedPrefixes <- S.get
  41                                 let fp = maybe
  42                                          (freshName usedPrefixes)
  43                                          (freshifyName usedPrefixes)
  44                                          mp
  45                                 S.modify' $ HS.insert fp
  46                                 return fp
  47          }
  48         where
  49         namespaces :: Namespaces (Maybe XML.NCName)
  50         namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns
  51
  52 coerceNS :: NS a -> NS b
  53 coerceNS = NS . unNS
  54 {-# INLINE coerceNS #-}
  55
  56 -- * 'freshifyName'
  57 poolNames :: [XML.NCName]
  58 poolNames = [ XML.NCName $ TL.pack ("ns"<>show i) | i <- [1 :: Int ..] ]
  59
  60 freshName :: HS.HashSet XML.NCName -> XML.NCName
  61 freshName ps = List.head $ poolNames List.\\ HS.toList ps
  62
  63 freshifyName :: HS.HashSet XML.NCName -> XML.NCName -> XML.NCName
  64 freshifyName ns (XML.NCName n) =
  65         let ints = [1..] :: [Int] in
  66         List.head
  67          [ fresh
  68          | suffix <- mempty : (show <$> ints)
  69          , fresh <- [ XML.NCName $ n <> TL.pack suffix]
  70          , not $ fresh `HS.member` ns
  71          ]
  72
  73 -- * Type 'Namespaces'
  74 data Namespaces prefix = Namespaces
  75  { namespaces_prefixes :: !(HM.HashMap XML.Namespace prefix)
  76  , namespaces_default  :: !XML.Namespace
  77  } deriving (Show)
  78 instance Default (Namespaces prefix) where
  79         def = Namespaces
  80          { namespaces_prefixes = HM.empty
  81          , namespaces_default  = ""
  82          }
  83 instance Semigroup (Namespaces XML.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 XML.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 XML.NCName) where
  94         mempty  = def
  95         mappend = (<>)
  96 instance Monoid (Namespaces (Maybe XML.NCName)) where
  97         mempty  = def
  98         mappend = (<>)
  99
 100 prefixifyQName :: Namespaces XML.NCName -> XML.QName -> XML.PName
 101 prefixifyQName Namespaces{..} XML.QName{..} =
 102         XML.PName
 103          { XML.pNameSpace =
 104                 if qNameSpace == namespaces_default
 105                 then Nothing
 106                 else HM.lookup qNameSpace namespaces_prefixes
 107          , XML.pNameLocal = qNameLocal
 108          }
 109
 110 -- * Type 'NS'
 111 -- | Collect 'Namespaces's and any prefixes associated with it,
 112 -- using 'State' to avoid recurring into already visited 'rule's.
 113 newtype NS a = NS { unNS :: S.State State (Namespaces (Maybe XML.NCName)) }
 114
 115 -- ** Type 'State'
 116 newtype State = State
 117  { state_rules :: {-!-}(HS.HashSet String)
 118  } deriving (Show)
 119 instance Default State where
 120         def = State
 121          { state_rules = HS.empty
 122          }
 123
 124 instance Show (NS a) where
 125         showsPrec p = showsPrec p . runNS . pure
 126 instance Semigroup (NS a) where
 127         NS x <> NS y = NS $ (<>) <$> x <*> y
 128 instance Monoid (NS a) where
 129         mempty  = NS $ return mempty
 130         mappend = (<>)
 131 instance Functor NS where
 132         fmap _f = coerceNS
 133 instance Applicative NS where
 134         pure _ = mempty
 135         NS f <*> NS x = NS f <> NS x
 136         NS f <*  NS x = NS f <> NS x
 137         NS f  *> NS x = NS f <> NS x
 138 instance Alternative NS where
 139         empty = mempty
 140         NS f <|> NS x = NS f <> NS x
 141         many = coerceNS
 142         some = coerceNS
 143 instance Sym_Rule NS where
 144         rule n (NS ns) = NS $ do
 145                 -- NOTE: avoid infinite loops
 146                 -- by not reentering into already visited rules.
 147                 st@State{..} <- S.get
 148                 if HS.member n state_rules
 149                  then return mempty
 150                  else do
 151                         S.put $ st{state_rules = HS.insert n state_rules}
 152                         ns
 153         arg _n = mempty
 154 type instance Perm NS = NS
 155 instance Sym_Interleaved NS where
 156         interleaved = coerceNS
 157         _f <$$> NS x        = NS x
 158         _f <$?> (_, NS x)   = NS x
 159         _f <$*> NS x        = NS x
 160         _f <$:> NS x        = NS x
 161         NS f <||> NS x      = NS f <> NS x
 162         NS f <|?> (_, NS x) = NS f <> NS x
 163         NS f <|*> NS x      = NS f <> NS x
 164 instance Sym_RNC NS where
 165         -- namespace n ns =
 166         --      NS $ return $ HM.singleton ns $ HS.singleton n
 167         namespace mp n =
 168                 NS $ return $
 169                 case mp of
 170                  Just p  -> def{namespaces_prefixes = HM.singleton n $ Just p}
 171                  Nothing -> def{namespaces_default = n}
 172         element XML.QName{..} (NS nsM) =
 173                 NS $ (<$> nsM) $ \ns -> ns{namespaces_prefixes =
 174                         HM.insert qNameSpace Nothing $ namespaces_prefixes ns}
 175         attribute XML.QName{..} (NS nsM) =
 176                 NS $ (<$> nsM) $ \ns -> ns{namespaces_prefixes =
 177                         HM.insert qNameSpace Nothing $ namespaces_prefixes ns}
 178         anyElem qNameSpace f =
 179                 let NS nsM = f $ XML.NCName "*" in
 180                 NS $ (<$> nsM) $ \ns -> ns{namespaces_prefixes =
 181                         HM.insert qNameSpace Nothing $ namespaces_prefixes ns}
 182         try         = id
 183         fail        = mempty
 184         text        = mempty
 185         any         = mempty
 186         choice      = mconcat
 187         option _def = coerceNS
 188         optional    = coerceNS
 189         manySeq     = coerceNS
 190         someSeq     = coerceNS