Symantic/RNC/Write/Namespaces.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module 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 Symantic.XML as XML
  20 import 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 Permutation NS = NS
  96 instance Sym_Permutation NS where
  97         runPermutation = coerceNS
  98         toPermutation = id
  99         toPermutationWithDefault _def = id
 100 instance Sym_RNC NS where
 101         -- namespace n ns =
 102         --      NS $ return $ HM.singleton ns $ HS.singleton n
 103         namespace mp n =
 104                 NS $ return $
 105                 case mp of
 106                  Just p  -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""}
 107                  Nothing -> def{XML.namespaces_default = n}
 108         element XML.QName{..} (NS nsM) =
 109                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 110                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 111         attribute XML.QName{..} (NS nsM) =
 112                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 113                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 114         anyElem qNameSpace f =
 115                 let NS nsM = f $ XML.NCName "*" in
 116                 NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
 117                         HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
 118         try         = id
 119         fail        = mempty
 120         escapedText = mempty
 121         text        = mempty
 122         any         = mempty
 123         choice      = mconcat
 124         option _def = coerceNS
 125         optional    = coerceNS
 126         manySeq     = coerceNS
 127         someSeq     = coerceNS