xml2json (empty) → 0.1.0.0
raw patch · 6 files changed
+310/−0 lines, 6 filesdep +aesondep +attoparsecdep +attoparsec-conduitsetup-changed
Dependencies added: aeson, attoparsec, attoparsec-conduit, base, blaze-builder, blaze-builder-conduit, bytestring, case-insensitive, conduit, tagstream-conduit, text, transformers, unordered-containers, vector
Files
- LICENSE +30/−0
- Main.hs +13/−0
- Setup.hs +2/−0
- Text/XML/ToJSON.hs +103/−0
- Text/XML/ToJSON/Builder.hs +70/−0
- xml2json.cabal +92/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, yihuang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of yihuang nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+import System.Environment (getArgs)+import Data.Conduit+import qualified Data.Conduit.Binary as C+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Aeson (encode)+import Text.XML.ToJSON (xmlToJSON)++main :: IO ()+main = do+ [name] <- getArgs+ json <- runResourceT $ xmlToJSON (C.sourceFile name)+ L.putStrLn $ encode json
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/XML/ToJSON.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.XML.ToJSON+ ( elementToJSON+ , tokensToJSON+ , xmlToJSON+ ) where++import Control.Monad (when)+import Control.Arrow (second)+import Control.Applicative ( (<$>), (*>) )++import Data.Maybe (fromMaybe)+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import Data.ByteString (ByteString)+import qualified Blaze.ByteString.Builder as B+import Data.Attoparsec.ByteString.Char8 (char)+import Data.Conduit+import Data.Conduit.Internal (ResumableSource(ResumableSource))+import qualified Data.Conduit.List as C+import qualified Data.Conduit.Attoparsec as C+import qualified Data.Conduit.Text as C+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as V++import Text.HTML.TagStream+import qualified Text.HTML.TagStream.Text as T+import qualified Text.HTML.TagStream.ByteString as S+import Text.XML.ToJSON.Builder+import Data.Aeson (Value(..), Object)++tokenToBuilder :: T.Token -> Builder+tokenToBuilder (TagOpen s as selfClose) = do+ beginElement s+ addAttrs as+ when selfClose endElement+tokenToBuilder (TagClose _) = endElement -- FIXME should match tag name?+tokenToBuilder (Text s) = addValue s+tokenToBuilder _ = return ()++attrsToObject :: [(Str, Str)] -> Object+attrsToObject = HM.fromList . map (second String)++mergeObject :: Value -> Value -> Value+mergeObject (Array arr) v = Array (V.cons v arr)+mergeObject v1 v2 = Array (V.fromList [v1, v2])++elementToJSON :: Element -> Value+elementToJSON (Element as vs cs) =+ if null as && null cs+ then+ String (T.concat vs)+ else+ Object $ HM.fromListWith mergeObject+ $ attrs+ ++ values+ ++ map (second elementToJSON) cs+ where+ attrs = if null as+ then []+ else [("__attributes", Object (attrsToObject as))]+ values = if null vs+ then []+ else [("__values", Array (V.fromList (map String vs)))]++tokensToJSON :: [T.Token] -> Value+tokensToJSON tokens =+ elementToJSON $ runBuilder (mapM_ tokenToBuilder tokens)++xmlToJSON :: (Functor m, Monad m, MonadThrow m) => Source m ByteString -> m Value+xmlToJSON src = do+ -- try to peek the first tag to find the xml encoding.+ (src', token) <- src $$+ C.sinkParser (char '<' *> S.tag)++ let (mencoding, src'') =+ case token of+ (TagOpen "?xml" as _) ->+ (lookup "encoding" as, src')+ _ ->+ ( Nothing+ , prependRSrc+ (yield (B.toByteString (S.showToken id token)))+ src'+ )++ codec = fromMaybe C.utf8 (mencoding >>= getCodec . CI.mk)++ tokensToJSON <$> (src'' $$+- (C.decode codec =$ T.tokenStream =$ C.consume))++prependRSrc :: Monad m+ => Source m a+ -> ResumableSource m a+ -> ResumableSource m a+prependRSrc src (ResumableSource src' close) = ResumableSource (src >> src') close++getCodec :: CI.CI ByteString -> Maybe C.Codec+getCodec c =+ case c of+ "utf-8" -> Just C.utf8+ "utf8" -> Just C.utf8+ "gbk" -> Just C.iso8859_1+ _ -> Nothing+
+ Text/XML/ToJSON/Builder.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.XML.ToJSON.Builder where++import Data.Text (Text)+import Control.Monad.Trans.State++type Str = Text++data Element = Element+ { elAttrs :: [(Str, Str)]+ , elValues :: [Str]+ , elChildren :: [(Str, Element)]+ } deriving (Show)++emptyElement :: Element+emptyElement = Element [] [] []++addChild' :: (Str, Element) -> Element -> Element+addChild' item o = o { elChildren = item : elChildren o }++addValue' :: Str -> Element -> Element+addValue' v o = o { elValues = v : elValues o }++addAttr' :: (Str, Str) -> Element -> Element+addAttr' attr o = o { elAttrs = attr : elAttrs o }++addAttrs' :: [(Str, Str)] -> Element -> Element+addAttrs' as o = o { elAttrs = as ++ elAttrs o }++type Stack = [(Str, Element)]+type Builder = State Stack ()++runBuilder :: Builder -> Element+runBuilder b = finishStack $ execState b [("", emptyElement)]++popStack :: Stack -> Stack+popStack ((k,v) : (name,elm) : tl) = (name, addChild' (k,v) elm) : tl+popStack _ = error "popStack: can't pop root elmect."++finishStack :: Stack -> Element+finishStack [] = error "finishStack: empty stack."+finishStack [(_, elm)] = elm+finishStack st = finishStack (popStack st)++beginElement :: Str -> Builder+beginElement name =+ modify ( (name, emptyElement) : )++endElement :: Builder+endElement =+ modify popStack++modifyTopElement :: (Element -> Element) -> Builder+modifyTopElement f =+ modify $ \st ->+ case st of+ ((k, v) : tl) -> (k, f v) : tl+ _ -> fail "modifyTopElement: impossible: empty stack."++addValue :: Str -> Builder+addValue = modifyTopElement . addValue'++addAttr :: (Str, Str) -> Builder+addAttr = modifyTopElement . addAttr'++addAttrs :: [(Str, Str)] -> Builder+addAttrs = modifyTopElement . addAttrs'++addChild :: (Str, Element) -> Builder+addChild = modifyTopElement . addChild'
+ xml2json.cabal view
@@ -0,0 +1,92 @@+-- Initial xml2json.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: xml2json++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: translate xml to json++-- A longer description of the package.+-- description: ++homepage: http://github.com/yihuang/xml2json++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: yihuang++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: yi.codeplayer@gmail.com++-- A copyright notice.+-- copyright: ++category: Text++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/yihuang/xml2json++library+ ghc-options: -Wall -O2+ -- Modules exported by the library.+ exposed-modules: Text.XML.ToJSON+ , Text.XML.ToJSON.Builder+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base ==4.*+ , transformers >=0.2+ , bytestring >=0.9+ , text >=0.11+ , blaze-builder ==0.3.*+ , case-insensitive ==0.4.*+ , unordered-containers >=0.2+ , vector >=0.9+ , vector >=0.9+ , attoparsec ==0.10.*+ , aeson ==0.6.*+ , conduit ==0.5.*+ , blaze-builder-conduit ==0.5.*+ , attoparsec-conduit ==0.5.*+ , tagstream-conduit ==0.5.*++executable xml2json+ main-is: Main.hs+ ghc-options: -Wall -O2+ build-depends: base ==4.*+ , transformers >=0.2+ , bytestring >=0.9+ , text >=0.11+ , blaze-builder ==0.3.*+ , case-insensitive ==0.4.*+ , unordered-containers >=0.2+ , vector >=0.9+ , attoparsec ==0.10.*+ , aeson ==0.6.*+ , conduit ==0.5.*+ , blaze-builder-conduit ==0.5.*+ , attoparsec-conduit ==0.5.*+ , tagstream-conduit ==0.5.*