diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/SXML.hs b/Text/SXML.hs new file mode 100644 --- /dev/null +++ b/Text/SXML.hs @@ -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 +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 ':' diff --git a/Text/SXML/Internal.hs b/Text/SXML/Internal.hs new file mode 100644 --- /dev/null +++ b/Text/SXML/Internal.hs @@ -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 diff --git a/Text/SXML/Utils.hs b/Text/SXML/Utils.hs new file mode 100644 --- /dev/null +++ b/Text/SXML/Utils.hs @@ -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 diff --git a/sxml.cabal b/sxml.cabal new file mode 100644 --- /dev/null +++ b/sxml.cabal @@ -0,0 +1,23 @@ +name: sxml +version: 0.1.0.0 +synopsis: A SXML-parser +description: This library parses and write files, using datatypes from the 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 +maintainer: ARJANEN Loïc Jean David +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