Permalink
Browse files

implemented namespaces

migrated from darcs:

Tue Nov 23 19:03:42 CET 2010  Johannes Wei� <weiss@tux4u.de>
  * FEATURE: implemented namespaces
  • Loading branch information...
1 parent 024b196 commit 9770c4ca9189d57ab5c30acca7bea05ebee5f467 @skogsbaer committed Jan 16, 2011
Showing with 138 additions and 39 deletions.
  1. +138 −39 src/Text/XML/Generator.hs
View
@@ -1,11 +1,15 @@
module Text.XML.Generator where
+import Control.Monad.Reader (Reader(..), ask, asks, runReader)
+import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BSL
import Data.Monoid
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
+import Debug.Trace
+
newtype Out t = Out { outBuf :: Builder }
data ATTR = ATTR
data ELEM = ELEM
@@ -18,13 +22,11 @@ type Uri = String
data Namespace
= DefaultNamespace
| QualifiedNamespace Prefix Uri
+ deriving (Show, Eq)
-data OutEnv
- = OutEnv
- { outEnv_counter :: Int
- , outEnv_namespaceMap :: Map Uri Int }
+type OutEnv = Map.Map Prefix Uri
-type Trans t = t -> Reader OutEnv t
+type Trans t = t -> Reader OutEnv (t, OutEnv)
{-
class XmlGen t where
@@ -45,58 +47,155 @@ instance XmlGen Out where
-}
xattr :: String -> String -> Trans Attr
-xattr key value (Out buffer)
- = Out (mconcat [buffer, spaceBuilder, keyBuilder, startBuilder, valueBuilder, endBuilder])
- where
- spaceBuilder = fromString " "
- keyBuilder = fromString key
- valueBuilder = fromString value
- startBuilder = fromString "=\""
- endBuilder = fromString "\""
+xattr = xattrQ DefaultNamespace
xelem :: String -> Trans Attr -> Trans Elem -> Trans Elem
-xelem name attrs elems (Out outBuffer)
- = endOut
- where
- startOut = Out (mconcat [outBuffer, fromString "<", fromString name])
- (Out attrsBuffer) = attrs startOut
- (Out elemsBuffer) = elems (Out $ mappend attrsBuffer (fromString "\n>"))
- endOut = Out (mconcat [elemsBuffer, fromString "</", fromString name, fromString "\n>"])
+xelem = xelemQ DefaultNamespace
xattrQ :: Namespace -> String -> String -> Trans Attr
-xattrQ = undefined
-
-xelemQ :: Namespace -> String -> Trans Attr -> Trans Elem -> TransElem
-xelemQ = undefined
+xattrQ ns' key value (Out buffer) =
+ do
+ uriMap' <- ask
+ let (ns, uriMap, newNs) = genValidNsForDesiredPrefix uriMap' ns'
+ let builder = case ns of
+ DefaultNamespace -> mconcat [ spaceBuilder, keyBuilder, startBuilder
+ , valueBuilder, endBuilder]
+ QualifiedNamespace p u ->
+ case newNs of
+ False -> mconcat [ spaceBuilder, prefixBuilder, colonBuilder
+ , keyBuilder, startBuilder
+ , valueBuilder, endBuilder]
+ True -> mconcat [ spaceBuilder, nsDeclStartBuilder, colonBuilder
+ , prefixBuilder, startBuilder, uriBuilder
+ , endBuilder, spaceBuilder, prefixBuilder
+ , colonBuilder, keyBuilder, startBuilder
+ , valueBuilder, endBuilder]
+ where
+ nsDeclStartBuilder = fromString "xmlns"
+ uriBuilder = fromString u
+ prefixBuilder = fromString p
+ colonBuilder = fromString ":"
+ return $ (Out (mconcat [buffer, builder]), uriMap)
+ where
+ spaceBuilder = fromString " "
+ keyBuilder = fromString key
+ valueBuilder = fromString value
+ startBuilder = fromString "=\""
+ endBuilder = fromString "\""
+
+xelemQ :: Namespace -> String -> Trans Attr -> Trans Elem -> Trans Elem
+xelemQ ns' name attrs elems (Out buffer)
+ = do
+ oldUriMap <- ask
+ let (ns, uriMap, newNs) = genValidNsForDesiredPrefix oldUriMap ns'
+ let elemNameBuilder = case ns of
+ DefaultNamespace -> fromString name
+ (QualifiedNamespace p u) -> mconcat [fromString p, fromString ":", fromString name]
+ let nsDeclBuilder = case ns of
+ DefaultNamespace -> mempty
+ (QualifiedNamespace p u) -> nsDeclaration
+ where nsDeclaration = if newNs then nsDeclaration' else mempty
+ nsDeclaration' = mconcat [fromString " xmlns:", fromString p, fromString "=\""
+ , fromString u, fromString "\""]
+ let startBuffer = mappend buffer $ fromString "<"
+ let startBuilder = mconcat [startBuffer, elemNameBuilder, nsDeclBuilder]
+
+ let (Out attrsBuffer, uriMapAttrs) = flip runReader uriMap $ attrs (Out startBuilder)
+ let (Out elemsBuffer) = fst $ flip runReader uriMapAttrs $ elems (Out $ mappend attrsBuffer (fromString "\n>"))
+ let endOut = Out (mconcat [elemsBuffer, fromString "</", elemNameBuilder, fromString "\n>"])
+ return (endOut, uriMapAttrs)
+
+eTrace :: (Show a) => a -> a
+eTrace a = trace ("TRACE: " ++ (show a)) a
+
+isDefaultNamespace :: Namespace -> Bool
+isDefaultNamespace (DefaultNamespace) = True
+isDefaultNamespace _ = False
+
+getPrefix :: Namespace -> Prefix
+getPrefix (QualifiedNamespace p _) = p
+getPrefix _ = error "error!"
+
+getUri :: Namespace -> Uri
+getUri (QualifiedNamespace _ u) = u
+getUri _ = error "error!"
xtext :: String -> Trans Elem
xtext content (Out buffer)
- = Out (buffer `mappend` fromString content)
-
-
-(<#>) :: Trans (Out t) -> Trans (Out t) -> Trans (Out t)
-(<#>) comb1 comb2 = comb2 . comb1
-
+ = return $ (Out (buffer `mappend` fromString content), error "uriMap of element evaluated")
+
+(<#>) :: Trans Elem -> Trans Elem -> Trans Elem
+(<#>) comb1 comb2 t
+ = do
+ state <- ask
+ let t2 = fst $ runReader (comb1 t) state
+ t3 = fst $ runReader (comb2 t2) state
+ return (t3, error "uriMap of element evaluated")
+
+(<@>) :: Trans Attr -> Trans Attr -> Trans Attr
+(<@>) comb1 comb2 t
+ = do
+ state <- ask
+ let (t2, state') = runReader (comb1 t) state
+ (t3, state'') = runReader (comb2 t2) state'
+ return (t3, state'')
+
+genValidNsForDesiredPrefix :: OutEnv -> Namespace -> (Namespace, OutEnv, Bool)
+genValidNsForDesiredPrefix env ns = eTrace $
+ case ns of
+ DefaultNamespace -> (ns, env, False)
+ QualifiedNamespace p u -> ( QualifiedNamespace validPrefix u
+ , Map.insert validPrefix u env
+ , not $ Map.member validPrefix env
+ )
+ where validPrefix = genValidPrefix env p u
+
+genValidPrefix :: OutEnv -> Prefix -> Uri -> Prefix
+genValidPrefix env prefix uri =
+ case Map.member prefix env of
+ False -> prefix
+ True -> let foundUri = Map.findWithDefault nextPrefix prefix env
+ nextPrefix = followingPrefix prefix
+ in if foundUri == uri then prefix else genValidPrefix env nextPrefix uri
+
+followingPrefix :: Prefix -> Prefix
+followingPrefix p = eTrace $ '_':p
xrender :: Trans Elem -> Builder
-xrender elem = outBuf (elem (Out $ mempty))
+xrender elem = buffer
+ where
+ (Out buffer) = fst $ runReader (elem (Out $ mempty)) emptyState
+
+emptyState :: OutEnv
+emptyState = Map.empty
-xempty :: Out t -> Out t
-xempty = id
+xempty :: Trans t
+xempty t = do
+ env <- ask
+ return (t, env)
test :: IO ()
test = BSL.putStr $ toLazyByteString $ xrender xsample
-nsFoo = ("http://www.factisresearch.com/ns/foo", "foo")
+_NS_PR1_NS1_ = QualifiedNamespace "foo" "urn:foo"
+_NS_PR4_NS1_ = QualifiedNamespace "___foo" "urn:foo"
+
+_NS_PR2_NS2_ = QualifiedNamespace "_foo" "urn:_foo"
+
+_NS_PR3_NS3_ = QualifiedNamespace "__foo" "urn:__foo"
+
+_NS_PR1_NS3_ = QualifiedNamespace "foo" "urn:bar"
-xelemFoo = xelem nsFoo
+testNS :: Namespace
+testNS = QualifiedNamespace "foo" "http://www.example.com"
-xsample :: Elem -> Elem
+xsample :: Trans Elem
xsample =
- xelem "foo" (xattr "key" "value")
- (xelem "bar" xempty (xtext "BAR")
+ xelemQ _NS_PR3_NS3_ "foo" ((xattrQ _NS_PR2_NS2_ "key" "value") <@> (xattrQ _NS_PR2_NS2_ "key2" "value"))
+ (xelemQ _NS_PR1_NS1_ "bar" (xattrQ _NS_PR2_NS2_ "key" "value") (xtext "BAR")
<#>
- xelem "spam" xempty (xelem "egg" xempty xempty <#> xtext "this is spam!"))
+ xelemQ _NS_PR1_NS1_ "bar" xempty
+ (xelemQ _NS_PR1_NS3_ "spam" xempty (xelem "egg" xempty xempty <#> xtext "this is spam!")))
-- sample (Out "")

0 comments on commit 9770c4c

Please sign in to comment.