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.Default.Class (Default(..))
   8 import Data.Function (($), (.), id)
   9 import Data.Functor (Functor(..))
  10 import Data.Maybe (Maybe(..), maybe, isNothing)
  11 import Data.Monoid (Monoid(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Text.Show (Show(..))
  14 import Data.String (String)
  15 import qualified Data.HashMap.Strict as HM
  16 import qualified Data.HashSet as HS
  17 import qualified Control.Monad.Trans.State.Strict as S
  18
  19 import qualified Language.Symantic.XML as XML
  20 import Language.Symantic.RNC.Sym
  21
  22 -- | Collect 'XML.Namespace's used and get them a dedicated prefix.
  23 runNS :: forall a. [NS a] -> XML.Namespaces XML.NCName
  24 runNS ns =
  25         namespaces
  26          { XML.namespaces_prefixes =
  27                 (`S.evalState` HS.empty) $
  28                         let prefixesByNamespace =
  29                                 HM.delete "" $ -- NOTE: no prefix when there is no namespace.
  30                                 HM.update -- NOTE: no prefix when this is the default namespace.
  31                                  (\p -> if isNothing p then Nothing else Just p)
  32                                  (XML.namespaces_default namespaces) $
  33                                 XML.namespaces_prefixes namespaces in
  34                         forM prefixesByNamespace $ \mp -> do
  35                                 usedPrefixes <- S.get
  36                                 let fp = maybe
  37                                          (XML.freshNCName usedPrefixes)
  38                                          (XML.freshifyNCName usedPrefixes)
  39                                          mp
  40                                 S.modify' $ HS.insert fp
  41                                 return fp
  42          }
  43         where
  44         namespaces :: XML.Namespaces (Maybe XML.NCName)
  45         namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns
  46
  47 coerceNS :: NS a -> NS b
  48 coerceNS = NS . unNS
  49 {-# INLINE coerceNS #-}
  50
  51 -- * Type 'NS'
  52 -- | Collect 'XML.Namespaces's and any prefixes associated with it,
  53 -- using 'State' to avoid recurring into already visited 'rule's.
  54 newtype NS a = NS { unNS :: S.State State (XML.Namespaces (Maybe XML.NCName)) }
  55
  56 -- ** Type 'State'
  57 newtype State = State
  58  { state_rules :: {-!-}(HS.HashSet String)
  59  } deriving (Show)
  60 instance Default State where
  61         def = State
  62          { state_rules = HS.empty
  63          }
  64
  65 instance Show (NS a) where
  66         showsPrec p = showsPrec p . runNS . pure
  67 instance Semigroup (NS a) where
  68         NS x <> NS y = NS $ (<>) <$> x <*> y
  69 instance Monoid (NS a) where
  70         mempty  = NS $ return mempty
  71         mappend = (<>)
  72 instance Functor NS where
  73         fmap _f = coerceNS
  74 instance Applicative NS where
  75         pure _ = mempty
  76         NS f <*> NS x = NS f <> NS x
  77         NS f <*  NS x = NS f <> NS x
  78         NS f  *> NS x = NS f <> NS x
  79 instance Alternative NS where
  80         empty = mempty
  81         NS f <|> NS x = NS f <> NS x
  82         many = coerceNS
  83         some = coerceNS
  84 instance Sym_Rule NS where
  85         rule n (NS ns) = NS $ do
  86                 -- NOTE: avoid infinite loops
  87                 -- by not reentering into already visited rules.
  88                 st@State{..} <- S.get
  89                 if HS.member n state_rules
  90                  then return mempty
  91                  else do
  92                         S.put $ st{state_rules = HS.insert n state_rules}
  93                         ns
  94         arg _n = mempty
  95 type instance Perm NS = NS
  96 instance Sym_Interleaved NS where
  97         interleaved = coerceNS
  98         _f <$$> NS x        = NS x
  99         _f <$?> (_, NS x)   = NS x
 100         _f <$*> NS x        = NS x
 101         _f <$:> NS x        = NS x
 102         NS f <||> NS x      = NS f <> NS x
 103         NS f <|?> (_, NS x) = NS f <> NS x
 104         NS f <|*> NS x      = NS f <> NS x
 105 instance Sym_RNC NS where
 106         -- namespace n ns =
 107         --      NS $ return $ HM.singleton ns $ HS.singleton n
 108         namespace mp n =
 109                 NS $ return $
 110                 case mp of
 111                  Just p  -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""}
 112                  Nothing -> def{XML.namespaces_default = n}
 113         element XML.QName{..} (NS nsM) =
 114                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 115                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 116         attribute XML.QName{..} (NS nsM) =
 117                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 118                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 119         anyElem qNameSpace f =
 120                 let NS nsM = f $ XML.NCName "*" in
 121                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 122                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 123         try         = id
 124         fail        = mempty
 125         escapedText = mempty
 126         text        = mempty
 127         any         = mempty
 128         choice      = mconcat
 129         option _def = coerceNS
 130         optional    = coerceNS
 131         manySeq     = coerceNS
 132         someSeq     = coerceNS