sxml (empty) → 0.1.0.0
raw patch · 6 files changed
+557/−0 lines, 6 filesdep +basedep +containersdep +polyparsesetup-changed
Dependencies added: base, containers, polyparse, text, xml-types
Files
- LICENSE +121/−0
- Setup.hs +2/−0
- Text/SXML.hs +321/−0
- Text/SXML/Internal.hs +62/−0
- Text/SXML/Utils.hs +28/−0
- sxml.cabal +23/−0
+ LICENSE view
@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++ CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+ LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+ ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+ INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+ REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+ PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+ THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+ HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++ i. the right to reproduce, adapt, distribute, perform, display,+ communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+ likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+ subject to the limitations in paragraph 4(a), below;+ v. rights protecting the extraction, dissemination, use and reuse of data+ in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+ European Parliament and of the Council of 11 March 1996 on the legal+ protection of databases, and under any national implementation+ thereof, including any amended or successor version of such+ directive); and+vii. other similar, equivalent or corresponding rights throughout the+ world based on applicable law or treaty, and any national+ implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+ surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+ warranties of any kind concerning the Work, express, implied,+ statutory or otherwise, including without limitation warranties of+ title, merchantability, fitness for a particular purpose, non+ infringement, or the absence of latent or other defects, accuracy, or+ the present or absence of errors, whether or not discoverable, all to+ the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+ that may apply to the Work or any use thereof, including without+ limitation any person's Copyright and Related Rights in the Work.+ Further, Affirmer disclaims responsibility for obtaining any necessary+ consents, permissions or other rights required for any use of the+ Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+ party to this document and has no duty or obligation with respect to+ this CC0 or use of the Work.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/SXML.hs view
@@ -0,0 +1,321 @@+-- | DOM-based parsing and rendering.+--+-- This module uses the datatypes from "Data.XML.Types", with the @String@-based+-- function being the “default” parsing one and the @Text.Lazy@-based one being+-- the “default” rendering one, @writeFile@ and @readFile@ being convenience+-- functions. It uses more or less the same naming conventions as <https://hackage.haskell.org/package/xml-conduit xml-conduit>+module Text.SXML+ ( -- * Parsing+ readFile+ -- ** String+ ,parseString+ -- ** Text+ ,parseText+ ,parseLazyText+ -- * Rendering+ ,writeFile+ -- ** String+ ,renderString+ -- ** Text+ ,renderText+ ,renderLazyText+ ) where++import Data.Monoid+import Data.Maybe+import Data.List+import Text.SXML.Internal+import Text.ParserCombinators.Poly.State+import Prelude hiding (readFile, writeFile)+import Control.Applicative hiding ((<|>),many)+import qualified System.IO as IO+import qualified Data.XML.Types as XT+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as TIO+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text as TS+import qualified Data.Map as M++type SXMLParser a = Parser [M.Map TS.Text (TS.Text, Maybe TS.Text)] Token a -- A parser accepts a stream of Token and uses a stack of maps from+ -- Text [the SXML prefix] to (Text, Maybe Text) [the URI and, if present, the original prefix]+ -- as state to store the currently active namespaces++readFile :: FilePath -> IO (Either String XT.Document)+readFile file = do+ sxml <- IO.readFile file+ return $ parseString sxml++parseText :: TS.Text -> Either String XT.Document+parseText = parseString . TS.unpack++parseLazyText :: T.Text -> Either String XT.Document+parseLazyText = parseString . T.unpack++parseString :: String -> Either String XT.Document+parseString txt = f3 $ runParser getSXML [M.empty] $ lexer txt+ where f3 (x,_,_) = x++writeFile :: FilePath -> XT.Document -> IO ()+writeFile file doc = TIO.writeFile file (renderLazyText doc)++renderText :: XT.Document -> TS.Text+renderText = T.toStrict . renderLazyText++renderString :: XT.Document -> String+renderString = T.unpack . renderLazyText++renderLazyText :: XT.Document -> T.Text+renderLazyText = TB.toLazyText . builderDoc+ where tagend = TB.singleton ')'+ tagstart = TB.singleton '('+ space = TB.singleton ' '+ empty = TB.fromString ""+ builderString txt =+ let toSchemeStringBuilder txt = fold_mod ((<>) . (<> TB.fromString "\\\\")) splitDoubleQuotes (TS.split (=='\\') txt)+ splitDoubleQuotes txt = fold_mod ((<>) . (<> TB.fromString "\\\"")) splitCarriageReturns (TS.split (=='"') txt)+ splitCarriageReturns txt = fold_mod ((<>) . (<> TB.fromString "\\r")) splitLineFeeds (TS.split (=='\r') txt)+ splitLineFeeds txt = fold_mod ((<>) . (<> TB.fromString "\\n")) splitFormFeeds (TS.split (=='\n') txt)+ splitFormFeeds txt = fold_mod ((<>) . (<> TB.fromString "\\f")) splitBackspaces (TS.split (=='\f') txt)+ splitBackspaces txt = fold_mod ((<>) . (<> TB.fromString "\\b")) splitTabulations (TS.split (=='\b') txt)+ splitTabulations txt = fold_mod ((<>) . (<> TB.fromString "\\t")) splitVerticalTab (TS.split (=='\t') txt)+ splitVerticalTab txt = fold_mod ((<>) . (<> TB.fromString "\\v")) TB.fromText (TS.split (=='\v') txt)+ fold_mod f t l = foldr1 f (map t l)+ stringsep = TB.singleton '"'+ in stringsep <> toSchemeStringBuilder txt <> stringsep+ nameToBuilder n = maybe empty ((<> TB.singleton ':') . TB.fromText) (XT.nameNamespace n) <> (TB.fromText . XT.nameLocalName $ n)+ builderDoc doc = TB.fromString "(*TOP*" <> (builderPrologue . sortBy prologueSorter $ ((XT.prologueBefore . XT.documentPrologue $ doc) ++ (XT.prologueAfter . XT.documentPrologue $ doc) ++ XT.documentEpilogue doc)) <> (builderElem . XT.documentRoot $ doc) <> tagend+ builderElem el = tagstart <> (nameToBuilder . XT.elementName $ el) <> space <> (builderAttrList . XT.elementAttributes $ el) <> (builderChildren . XT.elementNodes $ el) <> tagend+ builderContent (XT.ContentText t) = builderString t+ builderContent (XT.ContentEntity e) = TB.fromString "(*ENTITY* " <> TB.fromText e <> TB.fromString " \"\"" <> tagend+ builderInstruction (XT.Instruction tgt dat) = TB.fromString "(*PI* " <> TB.fromText tgt <> space <> builderString dat <> tagend+ builderComment ct = TB.fromString "(*COMMENT* " <> builderString ct <> tagend+ builderAttrList [] = empty+ builderAttrList al =+ let helperAttr [] = tagend+ helperAttr ((n,cs):ats) = tagstart <> nameToBuilder n <> helperAttrVal cs <> helperAttr ats+ helperAttrVal = foldr ((<>) . (space <>) . builderContent) tagend+ in TB.fromString "(@ " <> helperAttr al+ builderChildren [] = empty+ builderChildren (c:cs) =+ let helperChild (XT.NodeComment cmt) = builderComment cmt+ helperChild (XT.NodeInstruction instr) = builderInstruction instr+ helperChild (XT.NodeContent cnt) = builderContent cnt+ helperChild (XT.NodeElement elt) = builderElem elt+ in space <> helperChild c <> builderChildren cs+ builderPrologue [] = space+ builderPrologue (e:es) =+ let helperPrologue (XT.MiscInstruction instr) = builderInstruction instr+ helperPrologue (XT.MiscComment cmt) = builderComment cmt+ in space <> helperPrologue e <> builderPrologue es+ prologueSorter (XT.MiscInstruction _) (XT.MiscComment _) = GT+ prologueSorter (XT.MiscComment _) (XT.MiscInstruction _) = LT+ prologueSorter _ _ = EQ++getSXML :: SXMLParser XT.Document+getSXML = do+ lparen+ root+ pr <- prologue+ rEl <- element+ rparen+ return $ XT.Document pr rEl []++prologue :: SXMLParser XT.Prologue+prologue = do+ optional annotations+ pis <- many prologueProcInstr+ comments <- many prologueComment+ return $ XT.Prologue (pis ++ comments) Nothing []++prologueComment = do+ c <- commentHelper+ return $ XT.MiscComment c++comment = do+ c <- commentHelper+ return $ XT.NodeComment c++commentHelper = parens (cmt >> strTok)++prologueProcInstr = do+ inst <- prologueHelper+ return $ XT.MiscInstruction inst++procInstr = do+ inst <- prologueHelper+ return $ XT.NodeInstruction inst++prologueHelper = parens $ do+ pinst+ target <- nodeTok+ optional annotations+ instr <- strTok+ return $ XT.Instruction target instr++annotations = do+ lparen+ atl+ namespaces+ many annotation+ rparen+ return ()++annotation = do+ lparen+ name <- nodeTok+ target <- nodeTok <|> strTok+ rparen+ return ()++namespaces = do+ lparen+ nsl+ many namespace+ rparen+ return ()++namespace = do+ lparen+ nid <- nodeTok+ uri <- strTok+ oid <- optional nodeTok+ rparen+ stUpdate (\(cns:stns) -> (M.insert nid (uri, oid) cns : stns))+ return ()++helperName :: TS.Text -> SXMLParser XT.Name+helperName qname =+ let (prefv, uqnamev) = TS.breakOnEnd sep qname+ (pref, uqname) = if TS.null prefv then+ (TS.empty, uqnamev)+ else+ (TS.init prefv, uqnamev)+ in do+ nss <- stGet+ if TS.null pref then+ return $ XT.Name uqname Nothing Nothing+ else+ let lval = lookupS pref nss+ in case lval of+ Nothing -> return $ XT.Name uqname (Just pref) Nothing+ Just (uri, _) -> return $ XT.Name uqname (Just uri) (Just pref)++element :: SXMLParser XT.Element+element = do+ lparen+ eName <- nodeTok+ stUpdate (M.empty:)+ attrs <- optional annotAttributes+ let attrs' = fromMaybe [] attrs+ children <- many childOfElement+ rparen+ ename <- helperName eName+ stUpdate tail+ return $ XT.Element ename attrs' children++childOfElement = oneOf [elemText, comment, procInstr, entity, elementChild]++elementChild = do+ el <- element+ return $ XT.NodeElement el++attribute = do+ lparen+ name <- nodeTok+ val <- optional strTok+ optional annotations+ rparen+ atname <- helperName name+ case val of+ Nothing -> return (atname, [XT.ContentText $ XT.nameLocalName atname])+ Just v -> return (atname, [XT.ContentText v])++annotAttributes = do+ lparen+ atl+ attrs <- many attribute+ optional annotations+ rparen+ return attrs++entity = do+ lparen+ ent+ pid <- strTok+ sid <- strTok+ rparen+ return $ XT.NodeContent $ XT.ContentEntity pid++elemText = do+ val <- strTok+ return $ XT.NodeContent $ XT.ContentText val++root =+ satisfy' cdr "DocRoot"+ where cdr tok = case tok of+ DocRoot -> True+ _ -> False+cmt =+ satisfy' cct "Comment"+ where cct tok = case tok of+ Comment -> True+ _ -> False+ent =+ satisfy' cet "Entity"+ where cet tok = case tok of+ Entity -> True+ _ -> False+nsl =+ satisfy' cns "NamespacesList"+ where cns tok = case tok of+ NamespacesList -> True+ _ -> False+atl =+ satisfy' cal "AttributesList"+ where cal tok = case tok of+ AttributesList -> True+ _ -> False+pinst =+ satisfy' cpi "PI"+ where cpi tok = case tok of+ PI -> True+ _ -> False+lparen =+ satisfy' opp "OpenParen"+ where opp tok = case tok of+ OpenParen -> True+ _ -> False+rparen =+ satisfy' clp "CloseParen"+ where clp tok = case tok of+ CloseParen -> True+ _ -> False+strTok =+ (\(Str s) -> s) <$> satisfy' cs "Str"+ where cs tok = case tok of+ Str _ -> True+ _ -> False+nodeTok =+ (\(NodeName s) -> s) <$> satisfy' cn "NodeName"+ where cn tok = case tok of+ NodeName _ -> True+ _ -> False++satisfy' p attendu = do+ x <- next+ if p x+ then return x+ else case x of+ LexError s -> failBad s+ _ -> fail ("Error: " ++ attendu ++ " expected, was " ++ show x)++parens :: SXMLParser a -> SXMLParser a+parens = bracket lparen rparen++--lookupS :: TS.Text -> [M.Map TS.Text (TS.Text, Maybe TS.Text)] -> Maybe (TS.Text, Maybe TS.Text)+lookupS _ [] = Nothing+lookupS idx (m:ms) = case M.lookup idx m of+ Nothing -> lookupS idx ms+ Just uri -> Just uri++sep = TS.singleton ':'
+ Text/SXML/Internal.hs view
@@ -0,0 +1,62 @@+module Text.SXML.Internal(lexer, Token(..)) where++import Data.Char+import Text.SXML.Utils+import qualified Data.Text as T++data Token = OpenParen | CloseParen | DocRoot | NamespacesList | AttributesList | PI | Comment | Entity | Str T.Text | NodeName T.Text | LexError String deriving (Eq, Show)++lexer :: String -> [Token]+lexer = lexerh 0++lexerh _ "" = []+lexerh n (c:cs)+ | c == '(' = OpenParen : lexerh (n+1) cs+ | c == ')' = CloseParen : lexerh (n+1) cs+ | c == '@' = AttributesList : lexerh (n+1) cs+ | c == '*' = parseSpNode "" (n+1) cs+ | c == '"' = parseStr "" (n+1) cs+ | isSpace c = lexerh (n+1) cs+ | isXMLNameStartChar c = parseNode [c] (n+1) cs+ | otherwise = [LexError $ "Parsing error at position " ++ show n ++ ": invalid character at the start of an XML node name " ++ show c]+ where parseSpNode n _ ""+ | n == "*POT" = [DocRoot]+ | n == "*IP" = [PI]+ | n == "*SECAPSEMAN" = [NamespacesList]+ | n == "*TNEMMOC" = [Comment]+ | n == "*YTITNE" = [Entity]+ | otherwise = [NodeName (T.pack ('*': reverse n))]+ parseSpNode n x (c:cs) =+ if isSpace c+ then case n of+ "*POT" -> DocRoot : lexerh (x+1) cs+ "*IP" -> PI : lexerh (x+1) cs+ "*SECAPSEMAN" -> NamespacesList : lexerh (x+1) cs+ "*TNEMMOC" -> Comment : lexerh (x+1) cs+ "*YTITNE" -> Entity : lexerh (x+1) cs+ _ -> NodeName (T.pack ('*': reverse n)) : lexerh (x+1) cs+ else parseSpNode (c:n) (x+1) cs+ parseNode n _ "" = [NodeName . revpack $ n]+ parseNode n x (c:cs)+ | isSpace c = NodeName (revpack n) : lexerh (x+1) cs+ | isXMLNameChar c = parseNode (c:n) (x+1) cs+ | otherwise = [LexError $ "Parsing error at position " ++ show x ++ ": invalid character in an XML node name " ++ show c]+ parseStr n x "" = [LexError $ "Parsing error at position " ++ show x ++ ": unterminated string literal"]+ parseStr n x (c:cs) =+ case c of+ '"' -> Str (revpack n) : lexerh (x+1) cs+ '\\' -> parseEscape n (x+1) cs+ _ -> parseStr (c:n) (x+1) cs+ parseEscape n x "" = [LexError $ "Parsing error at position " ++ show x ++ ": unfinished string escape"]+ parseEscape n x (c:cs) =+ case c of+ '"' -> parseStr (c:n) (x+1) cs+ '\\' -> parseStr (c:n) (x+1) cs+ 'b' -> parseStr ('\b':n) (x+1) cs+ 'n' -> parseStr ('\n':n) (x+1) cs+ 'f' -> parseStr ('\f':n) (x+1) cs+ 'r' -> parseStr ('\r':n) (x+1) cs+ 't' -> parseStr ('\t':n) (x+1) cs+ 'v' -> parseStr ('\v':n) (x+1) cs+ _ -> [LexError $ "Parsing error at position " ++ show x ++ ": invalid string escape '\\" ++ [c] ++ "'"]+ revpack = T.pack . reverse
+ Text/SXML/Utils.hs view
@@ -0,0 +1,28 @@+-- | Utility functions.+--+-- This module contains utility functions which might be useful elsewhere.+-- So far, there are only functions to determine if a @String@ may be a+-- valid XML element name.+module Text.SXML.Utils(isXMLNameStartChar, isXMLNameChar, isXMLName) where++import Data.Char++(<||>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+p <||> q = \x -> p x || q x++-- | This function returns @True@ is its input is a valid character at the+-- beginning of an XML element name.+isXMLNameStartChar = (== ':') <||> (== '_') <||> isAsciiUpper <||> isAsciiLower <||> (`elem` ['\xc0'..'\xd6'])+ <||> (`elem` ['\xd8'..'\xf6']) <||> (`elem` ['\xf8'..'\x2ff']) <||> (`elem` ['\x370'..'\x37d'])+ <||> (`elem` ['\x37f'..'\x1fff']) <||> (`elem` ['\x200c'..'\x200d']) <||> (`elem` ['\x2070'..'\x218f'])+ <||> (`elem` ['\x2c00'..'\x2fef']) <||> (`elem` ['\x3001'..'\xd7ff']) <||> (`elem` ['\xf900'..'\xfdcf'])+ <||> (`elem` ['\xfdf0'..'\xfffd']) <||> (`elem` ['\x10000'..'\xeffff'])++-- | This function returns @True@ is its input is a valid character+-- within an XML element name.+isXMLNameChar = (== '-') <||> (== '.') <||> (== '·') <||> isDigit <||> isXMLNameStartChar <||> (`elem` ['\x300'..'\x36f']) <||> (`elem` ['\x203f'..'\x2040'])++-- | This function returns @True@ is its input is a valid XML+-- element name.+isXMLName "" = False+isXMLName (c:cs) = isXMLNameStartChar c || all isXMLNameChar cs
+ sxml.cabal view
@@ -0,0 +1,23 @@+name: sxml+version: 0.1.0.0+synopsis: A SXML-parser+description: This library parses and write <http://okmij.org/ftp/Scheme/SXML.html SXML> files, using datatypes from the <https://hackage.haskell.org/package/xml-types xml-types> package to represent their structure. It currently only features a DOM-style parser.+homepage: http://blog.luigiscorner.com/+license: PublicDomain+license-file: LICENSE+author: ARJANEN Loïc Jean David <arjanen.loic@gmail.com>+maintainer: ARJANEN Loïc Jean David <arjanen.loic@gmail.com>+copyright: © 2016 ARJANEN Loïc Jean David+category: Text, XML+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Text.SXML, Text.SXML.Utils+ other-modules: Text.SXML.Internal+ build-depends: base < 5, xml-types, text, containers, polyparse+ default-language: Haskell2010++Source-Repository head+ Type: darcs+ Location: http://hub.darcs.net/Azel/sxml