Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

fixed space leak

  • Loading branch information...
commit af3a45a1d98e34e798364b18a57f145deef0cb88 1 parent af6a411
Stefan Wehr authored

Showing 1 changed file with 11 additions and 12 deletions. Show diff stats Hide diff stats

  1. +11 12 src/Text/XML/Generator.hs
23 src/Text/XML/Generator.hs
... ... @@ -1,4 +1,4 @@
1   -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}
  1 +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses, BangPatterns #-}
2 2 module Text.XML.Generator (
3 3
4 4 Xml, Doc, DocInfo, Elem, Attr, Namespace, Prefix, Uri
@@ -63,10 +63,10 @@ data Namespace
63 63 ns :: Prefix -> Uri -> Namespace
64 64 ns = QualifiedNamespace
65 65
66   -type NsEnv = Map.Map Prefix Uri
  66 +newtype NsEnv = NsEnv { unNsEnv :: Map.Map Prefix Uri }
67 67
68 68 emptyNsEnv :: NsEnv
69   -emptyNsEnv = Map.empty
  69 +emptyNsEnv = NsEnv Map.empty
70 70
71 71 newtype Xml t = Xml { unXml :: Reader NsEnv (t, NsEnv) }
72 72
@@ -271,7 +271,7 @@ instance MkEmptyElem Namespace where
271 271 xelemQ :: AddChildren c => Namespace -> String -> c -> Xml Elem
272 272 xelemQ ns' name children = Xml $
273 273 do oldUriMap <- ask
274   - let (ns, uriMap, newNs) = genValidNsForDesiredPrefix oldUriMap ns'
  274 + let (ns, !uriMap, newNs) = oldUriMap `seq` genValidNsForDesiredPrefix oldUriMap ns'
275 275 let elemNameBuilder =
276 276 case ns of
277 277 DefaultNamespace -> fromString name
@@ -405,23 +405,22 @@ xrender r = fromBuilder $ builder r'
405 405 --
406 406
407 407 genValidNsForDesiredPrefix :: NsEnv -> Namespace -> (Namespace, NsEnv, Bool)
408   -genValidNsForDesiredPrefix env ns =
  408 +genValidNsForDesiredPrefix env@(NsEnv map) ns =
409 409 case ns of
410 410 DefaultNamespace -> (ns, env, False)
411 411 QualifiedNamespace p u ->
412   - let validPrefix = genValidPrefix env p u
  412 + let validPrefix = genValidPrefix map p u
413 413 in (QualifiedNamespace validPrefix u
414   - ,Map.insert validPrefix u env
415   - ,not $ Map.member validPrefix env)
  414 + ,NsEnv $ Map.insert validPrefix u map
  415 + ,not $ Map.member validPrefix map)
416 416 where
417   - genValidPrefix :: NsEnv -> Prefix -> Uri -> Prefix
418   - genValidPrefix env prefix uri =
419   - case Map.lookup prefix env of
  417 + genValidPrefix map prefix uri =
  418 + case Map.lookup prefix map of
420 419 Nothing -> prefix
421 420 Just foundUri ->
422 421 if foundUri == uri
423 422 then prefix
424   - else genValidPrefix env ('_':prefix) uri
  423 + else genValidPrefix map ('_':prefix) uri
425 424
426 425 {-# SPECIALIZE INLINE genericEscape ::
427 426 ((Char -> String -> String) -> String -> String -> String)

0 comments on commit af3a45a

Please sign in to comment.
Something went wrong with that request. Please try again.