├── utils ├── querydoc.ipkg └── QueryDoc.idr ├── xml-eff.ipkg ├── XML ├── DOM │ └── Eff.idr ├── XPath │ ├── Eff.idr │ ├── Types.idr │ ├── Parser.idr │ └── Query.idr ├── Serialise │ └── Eff.idr ├── Serialise.idr ├── Lexer.idr ├── Test │ ├── WellFormed.idr │ ├── XPath.idr │ └── NotWellFormed.idr ├── XPath.idr ├── Parser.idr └── DOM.idr ├── xml-test.ipkg ├── Makefile ├── xml.ipkg ├── LICENSE ├── README.org └── CONTRIBUTING.md /utils/querydoc.ipkg: -------------------------------------------------------------------------------- 1 | package querydoc 2 | 3 | pkgs = effects 4 | , lightyear 5 | , xml 6 | 7 | modules = QueryDoc 8 | 9 | main = QueryDoc 10 | 11 | executable = queryDoc 12 | -------------------------------------------------------------------------------- /xml-eff.ipkg: -------------------------------------------------------------------------------- 1 | package xml-eff 2 | 3 | author = Jan de Muijnck-Hughes 4 | maintainer = Jan de Muijnck-Hughes 5 | license = BSD3 but see LICENSE for more information 6 | brief = "XML & Effects in Idris" 7 | readme = README.md 8 | version = 0.1 9 | 10 | 11 | pkgs = effects 12 | 13 | , containers 14 | , commons 15 | , xml 16 | 17 | modules = XML.DOM.Eff 18 | , XML.Serialise.Eff 19 | , XML.XPath.Eff 20 | -------------------------------------------------------------------------------- /XML/DOM/Eff.idr: -------------------------------------------------------------------------------- 1 | ||| Convenience functions for working in Effectful functions. 2 | module XML.DOM.Eff 3 | 4 | import Effects 5 | import Effect.Exception 6 | 7 | import XML.DOM 8 | 9 | %access export 10 | 11 | getAttributeE : String 12 | -> Document ELEMENT 13 | -> {[EXCEPTION String]} Eff String 14 | getAttributeE id n = case getAttribute id n of 15 | Just res => pure res 16 | Nothing => raise $ "Element does not have: " ++ id 17 | 18 | -- --------------------------------------------------------------------- [ EOF ] 19 | -------------------------------------------------------------------------------- /xml-test.ipkg: -------------------------------------------------------------------------------- 1 | package xml-test 2 | 3 | author = Jan de Muijnck-Hughes 4 | maintainer = Jan de Muijnck-Hughes 5 | license = BSD3 but see LICENSE for more information 6 | brief = "XML in Idris" 7 | readme = README.md 8 | version = 0.1 9 | 10 | 11 | pkgs = effects 12 | , contrib 13 | , containers 14 | , commons 15 | 16 | modules = XML.Test.WellFormed 17 | , XML.Test.NotWellFormed 18 | , XML.Test.XPath 19 | 20 | tests = XML.Test.WellFormed.runTests 21 | , XML.Test.NotWellFormed.runTests 22 | , XML.Test.XPath.runTests 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ## Makefile 2 | 3 | IDRIS := idris 4 | LIB := xml 5 | OPTS := 6 | 7 | .PHONY: clean lib clobber check test doc 8 | 9 | install: lib 10 | ${IDRIS} ${OPTS} --install ${LIB}.ipkg 11 | ${IDRIS} ${OPTS} --install ${LIB}-eff.ipkg 12 | lib: 13 | ${IDRIS} ${OPTS} --build ${LIB}.ipkg 14 | 15 | clean: 16 | ${IDRIS} --clean ${LIB}.ipkg 17 | find . -name "*~" -delete 18 | 19 | clobber : clean 20 | find . -name "*.ibc" -delete 21 | 22 | check: clobber 23 | ${IDRIS} --checkpkg ${LIB}.ipkg 24 | 25 | test: 26 | ${IDRIS} --testpkg ${LIB}-test.ipkg 27 | 28 | doc: 29 | ${IDRIS} --mkdoc ${LIB}.ipkg 30 | -------------------------------------------------------------------------------- /xml.ipkg: -------------------------------------------------------------------------------- 1 | package xml 2 | 3 | author = Jan de Muijnck-Hughes 4 | maintainer = Jan de Muijnck-Hughes 5 | license = BSD3 but see LICENSE for more information 6 | brief = "XML in Idris" 7 | readme = README.md 8 | version = 0.1 9 | sourceloc = git://git@github.com:jfdm/idris-xml.git 10 | bugtracker = http://www.github.com/jfdm/idris-xml/issues 11 | 12 | 13 | pkgs = contrib 14 | , containers 15 | , commons 16 | 17 | modules = XML.DOM 18 | 19 | , XML.Lexer 20 | , XML.Parser 21 | 22 | , XML.Serialise 23 | 24 | , XML.XPath 25 | , XML.XPath.Parser 26 | , XML.XPath.Types 27 | , XML.XPath.Query 28 | -------------------------------------------------------------------------------- /XML/XPath/Eff.idr: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------- [ Eff.idr ] 2 | -- Module : Eff.idr 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | 7 | ||| XPath but in an effectfull context. 8 | module XML.XPath.Eff 9 | 10 | import Effects 11 | import Effect.Exception 12 | 13 | import XML.DOM 14 | import XML.XPath 15 | 16 | export 17 | queryE : String 18 | -> Document ty 19 | -> {auto prf : CanQuery ty} 20 | -> Eff (Either XPathError (ty' ** XPathResult ty')) xs 21 | queryE qstr doc {ty=ELEMENT} = pure (queryElem qstr doc) 22 | queryE qstr doc {ty=DOCUMENT} = pure (queryDoc qstr doc) 23 | 24 | 25 | -- --------------------------------------------------------------------- [ EOF ] 26 | -------------------------------------------------------------------------------- /XML/Serialise/Eff.idr: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------- [ Eff.idr ] 2 | -- Module : XML.Reader.Eff 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | module XML.Serialise.Eff 7 | 8 | import Lightyear 9 | import Lightyear.Strings 10 | import Lightyear.StringFile 11 | 12 | import Effects 13 | import Effect.File 14 | import Effect.Exception 15 | 16 | import XML.DOM 17 | import XML.Parser 18 | import XML.Serialise 19 | 20 | %access private 21 | 22 | export 23 | readXMLDoc : String 24 | -> Eff (Either XMLError (Document DOCUMENT)) 25 | [FILE ()] 26 | readXMLDoc f = parseFile CannotReadFile FileParseError parseXMLDoc f 27 | 28 | export 29 | readXMLSnippet : String 30 | -> Eff (Either XMLError (Document ELEMENT)) 31 | [FILE ()] 32 | readXMLSnippet f = parseFile CannotReadFile FileParseError parseXMLSnippet f 33 | 34 | -- --------------------------------------------------------------------- [ EOF ] 35 | -------------------------------------------------------------------------------- /utils/QueryDoc.idr: -------------------------------------------------------------------------------- 1 | module QueryDoc 2 | 3 | import System 4 | 5 | import Effects 6 | import Effect.System 7 | import Effect.File 8 | import Effect.StdIO 9 | import Effect.Exception 10 | 11 | import XML.DOM 12 | import XML.Reader 13 | import XML.XPath 14 | 15 | %default partial 16 | 17 | XEffs : List EFFECT 18 | XEffs = [SYSTEM, FILE_IO (), STDIO, EXCEPTION String] 19 | 20 | printRes : List XMLNode -> Eff () XEffs 21 | printRes Nil = pure () 22 | printRes (x::xs) = do 23 | putStrLn $ show @{xml} x 24 | printRes xs 25 | 26 | eMain : Eff () XEffs 27 | eMain = do 28 | [prog, fn, qstr] <- getArgs | Nil => raise "Cannot happen!" 29 | | [x] => raise "Need doc and query" 30 | | [x,y] => raise "Need Query" 31 | | _ => raise "To manny arguments" 32 | 33 | case !(readXMLDoc fn) of 34 | Left err => raise $ show err 35 | Right doc => do 36 | case query qstr doc of 37 | Left err => raise $ show err 38 | Right Nil => raise "Nothing Found" 39 | Right xs => printRes xs 40 | 41 | namespace Main 42 | main : IO () 43 | main = do 44 | run eMain 45 | exit 0 46 | -- --------------------------------------------------------------------- [ EOF ] 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Jan de Muijnck-Hughes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of the {organization} nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /XML/Serialise.idr: -------------------------------------------------------------------------------- 1 | -- -------------------------------------------------------------- [ Reader.idr ] 2 | -- Module : XML.reader 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | module XML.Serialise 7 | 8 | import Commons.Data.Location 9 | 10 | import XML.DOM 11 | import XML.Lexer 12 | import XML.Parser 13 | 14 | %access private 15 | 16 | public export 17 | data XMLError : Type where 18 | ParseError : Run.ParseError Token -> XMLError 19 | FileParseError : Run.ParseError Token -> String -> XMLError 20 | CannotReadFile : String -> FileError -> XMLError 21 | 22 | public export 23 | Show XMLError where 24 | show (ParseError err) = 25 | unlines [ unwords ["Error parsing was"] 26 | , case err of 27 | (FError e) => show e 28 | (PError e) => unlines [maybe "" show (location e), error e] 29 | (LError (MkLexFail l i)) => unlines [show l, show i] 30 | ] 31 | show (FileParseError err fn) = 32 | unlines [ unwords ["Error parsing file", show fn, "error was"] 33 | , case err of 34 | (FError e) => show e 35 | (PError e) => unlines [maybe "" show (location e), error e] 36 | (LError (MkLexFail l i)) => unlines [show l, show i] 37 | ] 38 | show (CannotReadFile fn err) = 39 | unlines [ unwords ["Cannot read file:", show fn, "error was"] 40 | , show err 41 | ] 42 | 43 | 44 | namespace Doc 45 | export 46 | fromString : String -> Either XMLError (Document DOCUMENT) 47 | fromString str = 48 | case parseXMLDoc str of 49 | Left err => Left $ ParseError err 50 | Right res => pure $ res 51 | 52 | namespace Snippet 53 | export 54 | fromString : String -> Either XMLError (Document ELEMENT) 55 | fromString str = do 56 | case parseXMLSnippet str of 57 | Left err => Left $ ParseError err 58 | Right res => pure $ res 59 | 60 | 61 | interface XMLReader a where 62 | fromSnippet : XMLElem -> Either XMLError a 63 | fromXMLDoc : XMLDoc -> Either XMLError a 64 | 65 | interface XMLWriter a where 66 | toXML : a -> XMLElem 67 | 68 | toXMLDoc : a -> XMLDoc 69 | toXMLDoc o = mkSimpleDocument (toXML o) 70 | 71 | 72 | 73 | 74 | -- --------------------------------------------------------------------- [ EOF ] 75 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Idris XML 2 | 3 | A Simple XML library for Idris. It is a work in construction, so things will fail. 4 | 5 | 6 | + This library has been inspired by [[http://www.yesodweb.com/book/xml][=xml-conduit=]]. 7 | + This library is not necessarily feature complete and will have missing functionality. 8 | + Name spaces are local only and prefix's are not parsed. 9 | + The XML declaration is not intelligent and checks for root element name is not performed. 10 | + Empty content in XML tags is parsed. 11 | + The DOM model is simple. 12 | + Things I would like to have but not necessarily the time for include: 13 | + Tests! 14 | + Possibe add a node operator class 15 | + Add Eq instance, may need to add shapes 16 | + QuasiQuotes idiomatic construction of documents within Idris. 17 | + Something more consice than the dom model. 18 | + Full implementation of XPath, or Cursor, or XQuery 19 | + XSD validation. 20 | + Better Soundness guarantees 21 | + using dependenty types 22 | + wrt xmlnode 23 | + XSLT transformation processing. 24 | + There are most likely things I would like to include but don't knwo that I need to include. If you know about this please consider contributing. 25 | 26 | * XPath Implementation 27 | 28 | The XPath implementation is not complete. This is due in part to: 29 | 30 | 1. I do not know how to implement the feature; 31 | 2. I do not need the feature so have not implemented the feature; 32 | 3. I couldn't care less about the feature; 33 | 4. I do not think it should be a feature. 34 | 35 | ** Contexts 36 | + Current Context :: =author= 37 | + Document Root :: =/bookstore= 38 | + Recursive Descent :: =//author= 39 | + Specific Elements :: =bookstore/book= 40 | 41 | ** Operators 42 | 43 | + Child =/= :: selects immediate children of the 44 | left-side collection. When this path operator appears at the 45 | start of the pattern, it indicates that children should be 46 | selected from the root node. 47 | + Recursive descent =//= :: searches for the specified element at any depth. When this path operator appears at the start of the pattern, it indicates recursive descent from the root node. 48 | + Wildcard =*= :: Not yet implemented. 49 | + Attributes =@= :: Not yet implemented 50 | ** Collections 51 | Operations on collections are not going to be supported. 52 | ** Filters and Filter Patterns 53 | Filters on collections are not going to be supported. 54 | ** Boolean, Comparison, and Set Expressions 55 | Boolean, comparison, set expressions are not going to be supported. 56 | ** Location Paths 57 | + Abbreviated location paths are supported only. 58 | *** Location Steps 59 | + Absolute and relative steps are supported. 60 | *** Axes 61 | Axes are partially supported. There will only be support for: 62 | + Child 63 | + Self 64 | + Attribute 65 | *** Node Tests 66 | + Name Tests are supported. 67 | + namespaces are not supported. 68 | + Node Type Tests are supported 69 | + only for comment, node and text. 70 | + only specified at the end of absolute paths. 71 | + Targeted Processing Instructions are not supported. 72 | *** Predicates 73 | Are not supported. 74 | -------------------------------------------------------------------------------- /XML/Lexer.idr: -------------------------------------------------------------------------------- 1 | module XML.Lexer 2 | 3 | import Text.Lexer 4 | 5 | import public Commons.Text.Lexer.Run 6 | 7 | %default total 8 | %access private 9 | 10 | 11 | public export 12 | data Token = Entity String 13 | | Struct String 14 | | Symbol String 15 | | Word String 16 | | Text String 17 | | Comment String 18 | | CData String 19 | | StringLit String 20 | | WS String 21 | | NotRecognised String 22 | | EndInput 23 | 24 | public export 25 | Eq Token where 26 | (==) (Entity x) (Entity y) = x == y 27 | (==) (Struct x) (Struct y) = x == y 28 | (==) (Symbol x) (Symbol y) = x == y 29 | (==) (Word x) (Word y) = x == y 30 | (==) (Text x) (Text y) = x == y 31 | (==) (Comment x) (Comment y) = x == y 32 | (==) (CData x) (CData y) = x == y 33 | (==) (StringLit x) (StringLit y) = x == y 34 | (==) (WS x) (WS y) = x == y 35 | (==) (NotRecognised x) (NotRecognised y) = x == y 36 | (==) EndInput EndInput = True 37 | (==) _ _ = False 38 | 39 | public export 40 | Show Token where 41 | show (Entity s) = "(Entity " ++ s ++ ")" 42 | show (Struct s) = "(Struct " ++ s ++ ")" 43 | show (Symbol s) = "(Symbol " ++ s ++ ")" 44 | show (Word s) = "(Word " ++ s ++ ")" 45 | show (Text s) = "(Text " ++ s ++ ")" 46 | show (Comment s) = "(Comment " ++ s ++ ")" 47 | show (CData s) = "(CData " ++ s ++ ")" 48 | show (StringLit s) = "(StringLit " ++ s ++ ")" 49 | show (WS s) = "(WS " ++ s ++ ")" 50 | show (NotRecognised s) = "(NotRecognised " ++ s ++ ")" 51 | show (EndInput) = "(EndInput)" 52 | 53 | word : Lexer 54 | word = alphaNums 55 | 56 | pathChar : Lexer 57 | pathChar = oneOf "\\.:#=?-!" 58 | 59 | url : Lexer 60 | url = some pathChar 61 | 62 | validSymbol : Lexer 63 | validSymbol = pathChar --<|> (non (oneOf "\"&'<>")) 64 | 65 | entity : Lexer 66 | entity = exact "&" 67 | <+> ((exact "quot") 68 | <|> (exact "amp") 69 | <|> (exact "apos") 70 | <|> (exact "lt") 71 | <|> (exact "gt")) 72 | <+> exact ";" 73 | 74 | nodeSymbol : Lexer 75 | nodeSymbol = exact "<" <|> exact ">" <|> exact "/" 76 | 77 | comment : Lexer 78 | comment = blockComment (exact "") 79 | 80 | cdata : Lexer 81 | cdata = blockComment (exact "") 82 | 83 | xmlChar : Lexer 84 | xmlChar = entity <|> non (oneOf "\"&'<>") <|> space 85 | 86 | xmlText : Lexer 87 | xmlText = (entity <|> non (oneOf "\"&'<>")) <+> some xmlChar <+> reject (exact "<") 88 | 89 | tokenMap : TokenMap Token 90 | tokenMap = 91 | [ (space, WS) 92 | , (comment, Comment) 93 | , (cdata, CData) 94 | , (stringLit, StringLit) 95 | , (nodeSymbol, Struct) 96 | , (entity, Entity) 97 | , (validSymbol, Symbol) 98 | , (word, Word) 99 | , (xmlText, Text) 100 | , (any, NotRecognised) 101 | ] 102 | 103 | keep : TokenData Token -> Bool 104 | keep t = case tok t of 105 | WS _ => False 106 | _ => True 107 | 108 | 109 | export 110 | XMLLexer : Lexer Token 111 | XMLLexer = MkLexer tokenMap keep EndInput 112 | 113 | export 114 | lexXMLStr : String -> Either LexError (List (TokenData Token)) 115 | lexXMLStr = lexString XMLLexer 116 | 117 | export 118 | lexXMLFile : String -> IO $ Either LexFail (List (TokenData Token)) 119 | lexXMLFile = lexFile XMLLexer 120 | -------------------------------------------------------------------------------- /XML/Test/WellFormed.idr: -------------------------------------------------------------------------------- 1 | -- ---------------------------------------------------------- [ WellFormed.idr ] 2 | -- Module : WellFormed.idr 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | module XML.Test.WellFormed 7 | 8 | import Test.Unit 9 | 10 | import Commons.Data.Location 11 | import Commons.Text.Parser.Test 12 | 13 | import XML.Lexer 14 | import XML.Parser 15 | import XML.DOM 16 | import XML.Serialise 17 | 18 | showParseError : Run.ParseError Token -> String 19 | showParseError (FError e) = show e 20 | showParseError (PError e) = unlines [maybe "" show (location e), error e] 21 | showParseError (LError (MkLexFail l i)) = unlines [show l, show i] 22 | 23 | 24 | export 25 | runTests : IO () 26 | runTests = do 27 | putStrLn $ "=> Well Formed" 28 | 29 | NonReporting.runTests [ 30 | runParseTest showParseError $ parseTest "Well Formed 1" (parseXMLSnippet) "\n" 31 | , runParseTest showParseError $ parseTest "Well Formed 2" (parseXMLSnippet) "" 32 | , runParseTest showParseError $ parseTest "Well Formed 3" (parseXMLSnippet) "asas asas" 33 | , runParseTest showParseError $ parseTest "Well Formed 4" (parseXMLSnippet) "" 34 | , runParseTest showParseError $ parseTest "Well Formed 5" (parseXMLSnippet) "" 35 | 36 | 37 | , runParseTest showParseError $ parseTest "Well Formed 6" (parseString XMLLexer comment) "" 38 | , runParseTest showParseError $ parseTest "Well Formed 7" (parseXMLSnippet) "1950-10-04" 39 | 40 | , runParseTest showParseError $ parseFail "Well Formed 8" (parseXMLSnippet) "" 41 | 42 | , runParseTest showParseError $ parseTest "Well Formed 9" (parseString XMLLexer instruction) "" 43 | , runParseTest showParseError $ parseTest"Well Formed 10" (parseXMLSnippet) "13" 44 | 45 | , runParseTest showParseError $ parseTest "Well Formed 11" (parseString XMLLexer xmlinfo) "" 46 | , runParseTest showParseError $ parseTest "Well Formed 12" (parseString XMLLexer xmlinfo) "" 47 | , runParseTest showParseError $ parseTest "Well Formed 13" (parseString XMLLexer doctype) "" 48 | , runParseTest showParseError $ parseTest "Well Formed 14" (parseXMLSnippet) "\n\n\n]]>\n\n\nA\n\n" 49 | 50 | , runParseTest showParseError $ parseTest "Well Formed 15" (parseXMLDoc) "]]>A" 51 | 52 | , runParseTest showParseError $ parseTest "Well Formed 16" (parseXMLSnippet) "asas" 53 | ] 54 | -- --------------------------------------------------------------------- [ EOF ] 55 | -------------------------------------------------------------------------------- /XML/XPath/Types.idr: -------------------------------------------------------------------------------- 1 | --- --------------------------------------------------------------- [ Types.idr ] 2 | -- Module : XML.XPath.Types 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- 6 | -- Types for an XPath EDSL. 7 | -- --------------------------------------------------------------------- [ EOH ] 8 | module XML.XPath.Types 9 | 10 | import public Commons.Data.Location 11 | import public Commons.Text.Lexer.Run 12 | import public Commons.Text.Parser.Support 13 | import public Commons.Text.Parser.Run 14 | 15 | import XML.DOM 16 | 17 | %default total 18 | %access public export 19 | 20 | public export 21 | data Token = ReservedNode String 22 | | UserNode String 23 | | Symbol String 24 | | WS String 25 | | NotRecog String 26 | | EndInput 27 | 28 | public export 29 | Eq Token where 30 | (==) (ReservedNode x) (ReservedNode y) = x == y 31 | (==) (UserNode x) (UserNode y) = x == y 32 | (==) (Symbol x) (Symbol y) = x == y 33 | (==) (NotRecog x) (NotRecog y) = x == y 34 | (==) EndInput EndInput = True 35 | (==) _ _ = False 36 | 37 | public export 38 | Show Token where 39 | show (ReservedNode s) = "(ReservedNode " ++ s ++ ")" 40 | show (UserNode s) = "(UserNode " ++ s ++ ")" 41 | show (Symbol s) = "(Symbol " ++ s ++ ")" 42 | show (WS s) = "(WS " ++ s ++ ")" 43 | show (NotRecog s) = "(NotRecog " ++ s ++ ")" 44 | show (EndInput) = "EndInput" 45 | 46 | 47 | data XPathTy = NODE | PATH | QUERY | ROOT | TEST Bool 48 | 49 | data ValidPath : (head : XPathTy) -> (tail : XPathTy) -> Type where 50 | AbsPathRoot : ValidPath ROOT NODE 51 | AbsPath : ValidPath ROOT PATH 52 | AbsPathEnd : ValidPath ROOT (TEST b) 53 | ValidSubEnd : ValidPath NODE (TEST b) 54 | ValidSubPath : ValidPath NODE NODE 55 | ValidSubPathPath : ValidPath NODE PATH 56 | 57 | infixl 2 58 | infixl 2 59 | 60 | ||| Add anynode for singular case '//node' 61 | ||| Attributes 62 | ||| Predicates 63 | data XPath : NodeTy -> XPathTy -> Type where 64 | ||| An XPath Query 65 | Query : XPath ty a -> XPath ty QUERY 66 | 67 | Any : XPath ELEMENT NODE 68 | Elem : String -> XPath ELEMENT NODE 69 | 70 | Attr : String -> XPath TEXT (TEST True) 71 | Text : XPath TEXT (TEST False) 72 | Comment : XPath COMMENT (TEST False) 73 | CData : XPath CDATA (TEST False) 74 | 75 | Root : XPath ELEMENT NODE -> XPath ELEMENT ROOT 76 | DRoot : XPath ELEMENT NODE -> XPath ELEMENT ROOT 77 | 78 | ||| An absolute path 79 | PathA : XPath ELEMENT a 80 | -> XPath tyB b 81 | -> (prf : ValidPath a b) 82 | -> XPath tyB PATH 83 | ||| Get decendants 84 | PathD : XPath ELEMENT a 85 | -> XPath tyB b 86 | -> (prf : ValidPath a b) 87 | -> XPath tyB PATH 88 | 89 | () : XPath ELEMENT a 90 | -> XPath tyB b 91 | -> {auto prf : ValidPath a b} 92 | -> XPath tyB PATH 93 | () a b {prf} = PathA a b prf 94 | 95 | 96 | () : XPath ELEMENT a 97 | -> XPath tyB b 98 | -> {auto prf : ValidPath a b} 99 | -> XPath tyB PATH 100 | () a b {prf} = PathD a b prf 101 | 102 | Show (XPath ty x) where 103 | show (Query q) = unwords ["[Query ", show q, "]\n"] 104 | show (Elem e) = e 105 | show (Any) = "*" 106 | show (Root r) = "/" ++ show r 107 | show (DRoot r) = "//" ++ show r 108 | show (Attr a) = "@" ++ a 109 | show (Text) = "text()" 110 | show (Comment) = "comment()" 111 | show (CData) = "cdata()" 112 | show (PathA p c prf) = show p ++ "/" ++ show c 113 | show (PathD p c prf) = show p ++ "//" ++ show c 114 | 115 | -- ------------------------------------------------------------------- [ ERROR ] 116 | 117 | data XPathError : Type where 118 | MalformedQuery : (qstr : String) -> Run.ParseError Token -> XPathError 119 | QueryError : (qstr : XPath ty a) -> (loc : XMLElem) -> (msg : Maybe String) -> XPathError 120 | SingletonError : String -> XPathError 121 | GenericError : String -> XPathError 122 | 123 | showParseError : Run.ParseError Token -> String 124 | showParseError (FError e) = show e 125 | showParseError (PError e) = unlines [maybe "" show (location e), error e] 126 | showParseError (LError (MkLexFail l i)) = unlines [show l, show i] 127 | 128 | Show XPathError where 129 | show (MalformedQuery q err) = unwords 130 | [ "Query:" 131 | , show q 132 | , "is malformed because" 133 | , showParseError err 134 | ] 135 | 136 | 137 | show (QueryError qstr loc msg) = unlines 138 | [ unwords ["QueryError:", fromMaybe "" msg] 139 | , "Asking for:" 140 | , unwords ["\t", show qstr] 141 | , "in" 142 | , unwords ["\t", (getTagName loc)]] 143 | show (GenericError msg) = unwords ["Generic Error:", msg] 144 | show (SingletonError m) = unwords ["At Least one node expected.", show m] 145 | -- --------------------------------------------------------------------- [ EOF ] 146 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | To a certain extent, I will welcome pull requests, bug reporting, and bug squashing! 4 | However, I will not provide guarantees that I will accept your pull request or ideas. 5 | I may infact reject them, or reimplmenet your ideas as I see fit. 6 | 7 | In the case I will accept your pull request, I would prefer that we came make it as easy as possible to contribute your changes to my code base. 8 | Here are a few guidelines that I would like contributors to follow so that we can have a chance of keeping on top of things. 9 | 10 | ## Getting Started 11 | 12 | 1. Make sure you are familiar with [Git](http://git-scm.com/book). 13 | 1. Make sure you have a [GitHub account](https://github.com/signup/free). 14 | 1. Make sure you are familiar with: [Idris](http://eb.host.cs.st-andrews.ac.uk/writings/idris-tutorial.pdf). 15 | 1. Make sure you can install `Idris`: 16 | * [Mac OS X](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-OS-X-using-Homebrew) 17 | * [Ubuntu](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Ubuntu) 18 | * [Debian](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Debian) 19 | * [Windows](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Windows) 20 | 21 | # Issue Reporting 22 | 23 | Before you report an issue, or wish to add cool functionality please try and check to see if there are existing [issues](https://github.com/jfdm/idris-xml/issues) and [pull requests](https://github.com/jfdm/idris-xml/pulls). 24 | I do not want you wasting your time, duplicating somebody's work! 25 | 26 | ## The Campsite Rule 27 | 28 | A basic rule when contributing to this project is the **campsite rule**: leave the codebase in better condition than you found it. 29 | Please clean up any messes that you find, and don't leave behind new messes for the next contributor. 30 | 31 | ## Making Changes 32 | 33 | Idris developers and hackers try to adhere to something similar to the [successful git branching model](http://nvie.com/posts/a-successful-git-branching-model/). 34 | I too try to adhere to the same model, but will not guarantee that I will. 35 | The steps are straightforward. 36 | 37 | ### New contributors 38 | 39 | For those new to the project: 40 | 41 | 1. Fork the [main development repository](https://github.com/jfdm/idris-xml) on github e.g. 42 | 2. Clone your fork to your local machine: 43 | 44 | ``` 45 | $ git clone git@github.com//idris-xml.git 46 | ``` 47 | 48 | 3. Add `jfdm/idris-xml` as a remote upstream 49 | 50 | ``` 51 | $ git remote add upstream git@github.com:jfdm/idris-xml.git 52 | ``` 53 | 54 | ### Existing Contributors 55 | 56 | For those already contributing to the project: 57 | 58 | 1. Ensure your existing clone is up-to-date with current `HEAD` e.g. 59 | 60 | ``` 61 | $ git fetch upstream 62 | $ git merge upstream/master 63 | ``` 64 | 65 | ### Remaining Steps 66 | 67 | The remaining steps are the same for both new and existing contributors: 68 | 69 | 1. Create, and checkout onto, a topic branch on which to base you work. 70 | * This is typically the master branch. 71 | * For your own sanity, please avoid working on the `master` branch. 72 | 73 | ``` 74 | $ git branch fix/master/my_contrib master 75 | $ git checkout fix/master/my_contrib 76 | ``` 77 | 78 | 1. Make commits of logical units. 79 | 1. Check for unnecessary whitespace with 80 | 81 | ``` 82 | $ git diff --check 83 | ``` 84 | 85 | 1. Make sure your commit messages are along the lines of: 86 | 87 | Short (50 chars or less) summary of changes 88 | 89 | More detailed explanatory text, if necessary. Wrap it to about 72 90 | characters or so. In some contexts, the first line is treated as the 91 | subject of an email and the rest of the text as the body. The blank 92 | line separating the summary from the body is critical (unless you omit 93 | the body entirely); tools like rebase can get confused if you run the 94 | two together. 95 | 96 | Further paragraphs come after blank lines. 97 | 98 | - Bullet points are okay, too 99 | 100 | - Typically a hyphen or asterisk is used for the bullet, preceded by a 101 | single space, with blank lines in between, but conventions vary here 102 | 103 | 1. Push your changes to a topic branch in your fork of the repository. 104 | 105 | ``` 106 | $ git push origin fix/master/my_contrib 107 | ``` 108 | 109 | 1. Go to GitHub and submit a pull request to `idris-xml` 110 | 111 | From there you will have to wait on my response to the request. 112 | This response might be an accept or some changes/improvements/alternatives will be suggest. 113 | We do not guarantee that all requests will be accepted. 114 | 115 | ## Increases chances of acceptance. 116 | 117 | To help increase the chance of your pull request being accepted: 118 | 119 | 1. Update the documentation, the surrounding one, examples elsewhere, guides, whatever is affected by your contribution 120 | 1. Use appropriate code formatting for `Idris` 121 | -------------------------------------------------------------------------------- /XML/XPath.idr: -------------------------------------------------------------------------------- 1 | -- --------------------------------------------------------------- [ XPath.idr ] 2 | -- Module : XPath.idr 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | module XML.XPath 7 | 8 | import XML.DOM 9 | 10 | import public XML.XPath.Types 11 | import XML.XPath.Parser 12 | 13 | %access export 14 | 15 | -- ------------------------------------------------------------------- [ Query ] 16 | 17 | public export 18 | data XPathResultTy = NODELIST | VALUE 19 | 20 | public export 21 | data XPathResult : NodeTy -> Type where 22 | Nodes : (prf : ValidNode a) 23 | -> List (Document a) 24 | -> XPathResult a 25 | Empty : XPathResult a 26 | 27 | foldResults : List (XPathResult a) -> XPathResult a 28 | foldResults = foldl merge Empty 29 | where 30 | merge : XPathResult a -> XPathResult a -> XPathResult a 31 | merge Empty y = y 32 | merge x Empty = x 33 | merge (Nodes prf xs) (Nodes x ys) = Nodes prf (xs ++ ys) 34 | 35 | concatMapResults : (Document ELEMENT -> XPathResult ty) -> XPathResult ELEMENT -> XPathResult ty 36 | concatMapResults f (Nodes prf xs) = foldResults $ Functor.map f xs 37 | concatMapResults f Empty = Empty 38 | 39 | private 40 | evaluatePath : (q : XPath ty a) 41 | -> Document ELEMENT 42 | -> XPathResult ty -- (calcResultTy q) 43 | 44 | evaluatePath (Query q) n = evaluatePath q n 45 | evaluatePath (Elem e) n = Nodes ValidElem $ getChildElementsByName e n 46 | evaluatePath (Any) n = Nodes ValidElem $ getChildElements n 47 | 48 | evaluatePath (Attr a) n with (getAttribute a n) 49 | evaluatePath (Attr a) n | Nothing = Empty 50 | evaluatePath (Attr a) n | (Just x) = Nodes ValidText [(mkText x)] 51 | 52 | 53 | evaluatePath (CData) n = Nodes ValidCData $ getCData n 54 | evaluatePath (Text) n = Nodes ValidText $ getText n 55 | evaluatePath (Comment) n = Nodes ValidDoc $ getComments n 56 | 57 | evaluatePath (Root r) n with (r) 58 | | Any = Nodes ValidElem [n] 59 | | Elem e = if getTagName n == e then Nodes ValidElem [n] else Empty 60 | 61 | evaluatePath (DRoot r) n with (r) 62 | | Any = Nodes ValidElem $ getAllChildren n 63 | | Elem e = Nodes ValidElem $ getElementsByName e n 64 | 65 | evaluatePath (PathA p child prf {a}) n = concatMapResults (evaluatePath child) (evaluatePath p n) 66 | 67 | evaluatePath (PathD p child prf) n with (child) 68 | evaluatePath (PathD p child prf) n | Any with (evaluatePath p n) 69 | evaluatePath (PathD p child prf) n | Any | (Nodes x xs) = 70 | Nodes ValidElem $ Foldable.concatMap (\x => getAllChildren x) xs 71 | evaluatePath (PathD p child prf) n | Any | Empty = Empty 72 | 73 | evaluatePath (PathD p child prf) n | (Elem x) with (evaluatePath p n) 74 | evaluatePath (PathD p child prf) n | (Elem x) | (Nodes ValidElem xs) = 75 | Nodes ValidElem $ Foldable.concatMap (\e => getElementsByName x e) xs 76 | evaluatePath (PathD p child prf) n | (Elem x) | Empty = Empty 77 | 78 | evaluatePath (PathD p child prf) n | path with (evaluatePath p n) 79 | evaluatePath (PathD p child prf) n | path | res = 80 | concatMapResults (evaluatePath path) res 81 | 82 | 83 | -- ------------------------------------------------------------------- [ Query ] 84 | 85 | export 86 | queryDoc : XPath ty QUERY 87 | -> Document DOCUMENT 88 | -> XPathResult ty 89 | queryDoc qstr doc = evaluatePath qstr (getRoot doc) 90 | 91 | export 92 | queryElem : XPath ty QUERY 93 | -> Document ELEMENT 94 | -> XPathResult ty 95 | queryElem qstr e = evaluatePath qstr e 96 | 97 | export 98 | query : XPath qTy QUERY 99 | -> Document ty 100 | -> {auto prf : CanQuery ty} 101 | -> XPathResult qTy 102 | query q x {prf} with (prf) 103 | query q x {prf = prf} | QueryDoc = queryDoc q x 104 | query q x {prf = prf} | QueryElem = queryElem q x 105 | 106 | 107 | -- ------------------------------------------------------------------ [ Parser ] 108 | 109 | namespace String 110 | export 111 | queryDoc : String 112 | -> Document DOCUMENT 113 | -> Either XPathError (ty ** XPathResult ty) 114 | queryDoc qstr doc = 115 | case (parseXPathStr qstr) of 116 | Left err => Left $ MalformedQuery qstr err 117 | Right (_ ** q) => Right $ (_ ** queryDoc q doc) 118 | 119 | export 120 | queryElem : String 121 | -> Document ELEMENT 122 | -> Either XPathError (ty ** XPathResult ty) 123 | queryElem qstr e = do 124 | case (parseXPathStr qstr) of 125 | Left err => Left $ MalformedQuery qstr err 126 | Right (_ ** q) => Right $ (_ ** queryElem q e) 127 | 128 | export 129 | query : String 130 | -> Document ty 131 | -> {auto prf : CanQuery ty} 132 | -> Either XPathError (ty' ** XPathResult ty') 133 | query qstr x {prf} with (prf) 134 | query qstr x {prf = prf} | QueryDoc = queryDoc qstr x 135 | query qstr x {prf = prf} | QueryElem = queryElem qstr x 136 | 137 | 138 | -- --------------------------------------------------------------------- [ EOF ] 139 | -------------------------------------------------------------------------------- /XML/Test/XPath.idr: -------------------------------------------------------------------------------- 1 | module XML.Test.XPath 2 | 3 | import Text.PrettyPrint.WL 4 | 5 | import Test.Unit.Display 6 | import Test.Unit 7 | 8 | import Commons.Text.Parser.Test 9 | 10 | import XML.DOM 11 | import XML.XPath 12 | 13 | import XML.XPath.Parser 14 | 15 | 16 | bstore : Document DOCUMENT 17 | bstore = mkSimpleDocument root 18 | where 19 | rogElem : Document ELEMENT 20 | rogElem = "isbn" <+=> "123" 21 | 22 | book1 : Document ELEMENT 23 | book1 = mkSimpleElement "book" 24 | <++> ("title" <+=> "Harry Potter") 25 | <++> ("price" <+=> "29.99") 26 | 27 | 28 | book2 : Document ELEMENT 29 | book2 = mkSimpleElement "book" 30 | <++> ("title" <+=> "Learning XML") 31 | <++> ("price" <+=> "39.35") 32 | <++> ("isbn" <+=> "123456") 33 | 34 | root : Document ELEMENT 35 | root = mkSimpleElement "bookstore" <++> book1 <++> book2 <++> rogElem 36 | 37 | 38 | 39 | people : Document DOCUMENT 40 | people = mkSimpleDocument root 41 | where 42 | p1 : Document ELEMENT 43 | p1 = mkElementPrefix "person" "pre" <=> "Michael" 44 | 45 | p2 : Document ELEMENT 46 | p2 = "person" <+=> "Eliezer" 47 | 48 | root : Document ELEMENT 49 | root = mkSimpleElement "people" <++> p1 <++> p2 50 | 51 | 52 | mkBook : String -> String -> String -> String -> String -> String -> Document ELEMENT 53 | mkBook n a d f l p = mkSimpleElement "book" 54 | <++> ("title" <+=> n) 55 | <++> ("author" <+=> a) 56 | <++> ("desc" <+=> d) 57 | <++> ("format" <+=> l) 58 | <++> ("price" <+=> p) 59 | 60 | ||| http://en.wikibooks.org/wiki/XQuery/XPath_examples 61 | books : Document DOCUMENT 62 | books = mkSimpleDocument root 63 | where 64 | desc : Document ELEMENT 65 | desc = "desc" <+=> "A list of books useful for people first learning how to build web XML web applications." 66 | 67 | book1 : Document ELEMENT 68 | book1 = mkBook "XQuery" 69 | "Priscilla Walmsley" 70 | "This book is a highly detailed, through and complete tour of the W3C Query language. It covers all the key aspects of the language as well as" 71 | "Trade press" 72 | "Commercial" 73 | "49.95" 74 | 75 | book2 : Document ELEMENT 76 | book2 = mkBook "XQuery Examples" 77 | "Chris Wallace" 78 | "This book provides a variety of XQuery example programs and is designed to work with the eXist open-source native XML application server." 79 | "Wiki-books" 80 | "Creative Commons Sharealike 3.0 Attribution-Non-commercial" 81 | "29.95" 82 | book3 : Document ELEMENT 83 | book3 = mkBook "XForms Tutorial and Cookbook" 84 | "Dan McCreary" 85 | "This book is an excellent guide for anyone that is just beginning to learn the XForms standard. The book is focused on providing the reader with simple, but complete examples of how to create XForms web applications." 86 | "Wikibook" 87 | "Creative Commons Sharealike 3.0 Attribution-Non-commercial" 88 | "29.95" 89 | 90 | book4 : Document ELEMENT 91 | book4 = mkBook "XRX: XForms, Rest and XQuery" 92 | "Dan McCreary" 93 | "This book is an overview of the key architectural and design patters." 94 | "Wikibook" 95 | "Creative Commons Sharealike 3.0 Attribution-Non-commercial" 96 | "29.95" 97 | 98 | root : Document ELEMENT 99 | root = mkSimpleElement "books" 100 | <++> desc 101 | <++> book1 102 | <++> book2 103 | <++> book3 104 | <++> book4 105 | 106 | 107 | myQuery : XPath ELEMENT QUERY 108 | myQuery = Query $ 109 | (Root (Elem "bookstore")) 110 | ((Elem "book") 111 | (Elem "title")) 112 | 113 | queryTest : String 114 | -> String 115 | -> Document DOCUMENT 116 | -> Bool 117 | -> IO Bool 118 | queryTest title q doc chk = do 119 | putStrLn $ unwords ["Test:" , title] 120 | case queryDoc q doc of 121 | Left err => do 122 | when (chk) $ do 123 | let errMsg = vcat [ 124 | text errLine 125 | , text "An error occured" <+> colon 126 | , indent 2 $ text (show err) 127 | , text errLine] 128 | putStrLn $ Default.toString errMsg 129 | if chk 130 | then pure False 131 | else pure True 132 | Right ( _ ** Empty) => do 133 | putStrLn "Empty" 134 | pure False 135 | Right (_ ** Nodes _ ns) => do 136 | printLn ns 137 | pure chk 138 | 139 | export 140 | runTests : IO () 141 | runTests = do 142 | putStrLn $ "=> XPath" 143 | 144 | NonReporting.runTests 145 | [ runParseTest showParseError $ parseTest "Query 1" (parseXPathStr) "/root/@test" 146 | , runParseTest showParseError $ parseTest "Query 2" (parseXPathStr) "/root/text()" 147 | , runParseTest showParseError $ parseTest "Query 3" (parseXPathStr) "/bookstore/book/title" 148 | , queryTest "Query 4" "/books/book/title" books True 149 | ] 150 | -------------------------------------------------------------------------------- /XML/XPath/Parser.idr: -------------------------------------------------------------------------------- 1 | -- -------------------------------------------------------------- [ Parser.idr ] 2 | -- Module : XML.XPath.Parser 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- 6 | -- Turn an xpath dsl instance to edsl 7 | -- --------------------------------------------------------------------- [ EOH ] 8 | module XML.XPath.Parser 9 | 10 | import public Text.Lexer 11 | import public Text.Parser 12 | 13 | import public Commons.Text.Lexer.Run 14 | import public Commons.Text.Parser.Support 15 | import public Commons.Text.Parser.Run 16 | 17 | import XML.DOM 18 | 19 | import XML.XPath.Types 20 | 21 | %access private 22 | 23 | keywords : List String 24 | keywords = ["text", "comment", "cdata"] 25 | 26 | symbols : String 27 | symbols = "@()*/" 28 | 29 | 30 | tokenMap : TokenMap Token 31 | tokenMap = 32 | [ (space, WS) 33 | , (oneOf symbols, Symbol) 34 | ] 35 | ++ 36 | Functor.map (\x => (exact x, ReservedNode)) keywords 37 | ++ 38 | [ (alphaNums, UserNode) 39 | , (any, NotRecog) 40 | ] 41 | 42 | keep : TokenData Token -> Bool 43 | keep t = case tok t of 44 | WS _ => False 45 | _ => True 46 | 47 | export 48 | XPathLexer : Lexer Token 49 | XPathLexer = MkLexer tokenMap keep EndInput 50 | 51 | export 52 | lexXPathStr : String -> Either LexError (List (TokenData Token)) 53 | lexXPathStr = lexString XPathLexer 54 | 55 | export 56 | lexXPathFile : String -> IO $ Either LexFail (List (TokenData Token)) 57 | lexXPathFile = lexFile XPathLexer 58 | 59 | 60 | public export 61 | Parser : (a : Type) -> Type 62 | Parser = Rule Token 63 | 64 | ParserE : (a : Type) -> Type 65 | ParserE = RuleEmpty Token 66 | 67 | eoi : RuleEmpty Token () 68 | eoi = eoi isEOI 69 | 70 | where 71 | isEOI : Token -> Bool 72 | isEOI EndInput = True 73 | isEOI _ = False 74 | 75 | nodeIs : String -> Parser () 76 | nodeIs str = 77 | match ("Expected Symbol '" ++ str ++ "'") 78 | () 79 | (ReservedNode str) 80 | 81 | node : Parser String 82 | node = terminalF "Expected node" 83 | (\x => case tok x of 84 | (UserNode s) => Just s 85 | _ => Nothing) 86 | 87 | symbol : String -> Parser () 88 | symbol str = 89 | match ("Expected Symbol '" ++ str ++ "'") 90 | () 91 | (Symbol str) 92 | 93 | parens : Parser () 94 | parens = symbol "(" *> symbol ")" *> pure () 95 | 96 | -- -------------------------------------------------------------------- [ Test ] 97 | 98 | nodeTest : Parser $ (b ** ty ** XPath ty (TEST b)) 99 | nodeTest = 100 | nodeIs "text" *> parens *> pure (_ ** _ ** Text) 101 | <|> nodeIs "comment" *> parens *> pure (_ ** _ ** Comment) 102 | <|> nodeIs "cdata" *> parens *> pure (_ ** _ ** CData) 103 | <|> do symbol "@" 104 | w <- node 105 | pure (_ ** _ ** Attr w) 106 | 107 | -- ------------------------------------------------------------------- [ Nodes ] 108 | 109 | nodeStr : Parser (XPath ELEMENT NODE) 110 | nodeStr = 111 | do n <- node 112 | pure (Elem n) 113 | 114 | nodeAny : Parser (XPath ELEMENT NODE) 115 | nodeAny = symbol "*" *> pure Any 116 | 117 | 118 | nodeXPath : Parser (XPath ELEMENT NODE) 119 | nodeXPath = nodeAny <|> nodeStr 120 | 121 | -- ------------------------------------------------------------------- [ Roots ] 122 | 123 | aRoot : Parser (XPath ELEMENT ROOT) 124 | aRoot = do symbol "/" 125 | n <- nodeXPath 126 | pure (Root n) 127 | 128 | dRoot : Parser $ XPath ELEMENT ROOT 129 | dRoot = do symbol "/" 130 | symbol "/" 131 | n <- nodeXPath 132 | pure $ DRoot n 133 | 134 | root : Parser $ XPath ELEMENT ROOT 135 | root = aRoot <|> dRoot 136 | 137 | -- ------------------------------------------------------------------- [ Paths ] 138 | 139 | data ParseRes = P (XPath ty PATH) 140 | | N (XPath ty NODE) 141 | | T (XPath ty (TEST b)) 142 | 143 | mutual 144 | pathelem : Parser $ ParseRes 145 | pathelem = do {res <- nodeTest; pure $ T (snd (snd res))} 146 | <|> do {res <- decpath; pure $ P (snd res)} 147 | <|> do {res <- anypath; pure $ P (snd res)} 148 | <|> map N nodeXPath 149 | 150 | thing : XPath ELEMENT ROOT -> ParseRes -> (ty ** XPath ty PATH) 151 | thing r (P p) = (_ ** r p) 152 | thing r (N n) = (_ ** r n) 153 | thing r (T t) = (_ ** r t) 154 | 155 | thing' : XPath ELEMENT NODE -> ParseRes -> (ty ** XPath ty PATH) 156 | thing' r (P p) = (_ ** r p) 157 | thing' r (N n) = (_ ** r n) 158 | thing' r (T t) = (_ ** r t) 159 | 160 | 161 | abspath : Parser $ (ty ** XPath ty PATH) 162 | abspath = do r <- root 163 | symbol "/" 164 | pelem <- pathelem 165 | pure (thing r pelem) 166 | 167 | anypath : Parser $ (ty ** XPath ty PATH) 168 | anypath = do r <- nodeXPath 169 | symbol "/" 170 | pelem <- pathelem 171 | pure (thing' r pelem) 172 | 173 | decpath : Parser $ (ty ** XPath ty PATH) 174 | decpath = do r <- nodeXPath 175 | symbol "/" 176 | symbol "/" 177 | 178 | pelem <- pathelem 179 | pure (thing' r pelem) 180 | 181 | path : Parser $ (ty ** XPath ty PATH) 182 | path = decpath <|> anypath <|> abspath 183 | 184 | export 185 | query : Parser $ (ty ** XPath ty QUERY) 186 | query = do {res <- nodeTest; pure (_ ** Query (snd (snd res)))} 187 | <|> do {res <- path; pure (_** Query (snd res))} 188 | <|> do {res <- root; pure (_ ** Query res)} 189 | <|> do {res <- nodeXPath; pure (_ ** Query res)} 190 | {- 191 | export 192 | parseQuery : Parser $ (ty ** XPath ty QUERY) 193 | parseQuery = do (_ ** _ ** res) <- nodetest; pure $ (_ ** Query res) 194 | <|> do (_ ** res) <- path; pure $ (_ ** Query res) 195 | <|> do res <- root; pure (_ ** Query res) 196 | <|> do res <- node; pure (_ ** Query res) 197 | "XPath Query" 198 | -} 199 | 200 | 201 | export 202 | parseXPathStr : (doc : String) 203 | -> (Either (Run.ParseError Token) (ty ** XPath ty QUERY)) 204 | parseXPathStr = parseString XPathLexer query 205 | 206 | 207 | export 208 | parseXMLPathFile : (fname : String) 209 | -> IO (Either (Run.ParseError Token) (ty ** XPath ty QUERY)) 210 | parseXMLPathFile = parseFile XPathLexer query 211 | 212 | 213 | -- --------------------------------------------------------------------- [ EOF ] 214 | -------------------------------------------------------------------------------- /XML/XPath/Query.idr: -------------------------------------------------------------------------------- 1 | -- --------------------------------------------------------------- [ Query.idr ] 2 | -- Module : Query.idr 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | ||| Predefined Query Wrappers for XPath stuff. 7 | module XML.XPath.Query 8 | 9 | import XML.DOM 10 | import XML.XPath 11 | 12 | %access export 13 | 14 | ||| Use XPath to find some nodes satisfying some query 15 | ||| 16 | ||| @convErr Convert XPathError to a local Error Type 17 | ||| @qstr The query to run. 18 | ||| @node The thing we are querying 19 | getNodes : (convErr : XPathError -> a) 20 | -> (qstr : String) 21 | -> (node : Document ty) 22 | -> {auto prf : CanQuery ty} 23 | -> Either a (ty' ** XPathResult ty') 24 | getNodes convErr qstr doc = 25 | case query qstr doc of 26 | Left err => Left $ convErr err 27 | Right res => Right res 28 | 29 | ||| Use XPath to find the first node that satisfies some query. 30 | ||| 31 | ||| @convErr Convert XPathError to a local Error Type 32 | ||| @qstr The query to run. 33 | ||| @node The thing we are querying 34 | getNode : (convErr : XPathError -> a) 35 | -> (qstr : String) 36 | -> (node : Document ty) 37 | -> {auto prf : CanQuery ty} 38 | -> Either a (ty' ** Document ty') 39 | getNode convErr qstr doc = do 40 | (_ ** res) <- getNodes convErr qstr doc 41 | case res of -- QueryError qstr loc msg 42 | Empty => Left (convErr $ SingletonError qstr) 43 | (Nodes _ (x::_)) => Right (_ ** x) 44 | 45 | 46 | ||| Use XPath to find nodes satisfying some query get the text or 47 | ||| cdata inside or a specific attribute. 48 | ||| 49 | ||| @test The test to execute. 50 | ||| @convErr Convert XPathError to a local error type. 51 | ||| @qstr The query to run. 52 | ||| @node The thing we are querying. 53 | getNodeValues : (test : XPath ty' (TEST b)) 54 | -> (convErr : XPathError -> a) 55 | -> (qstr : String) 56 | -> (node : Document ty) 57 | -> {auto prfB : ValidNode ty} 58 | -> {auto prf : CanQuery ty} 59 | -> Either a (List String) 60 | getNodeValues test convErr qstr doc = do 61 | (_ ** res) <- getNodes convErr (concat [qstr, "/", show test]) doc 62 | case res of 63 | Empty => pure Nil 64 | (Nodes prf xs) => do 65 | let vals = mapMaybe (\x => getNodeValue {prf=prf} x) xs 66 | pure vals 67 | 68 | ||| Use XPath to find the first node that satisfies some query get the 69 | ||| text or cdata inside or a specific attribute. 70 | ||| 71 | ||| @test The test to execute. 72 | ||| @convErr Convert XPathError to a local error type. 73 | ||| @qstr The query to run. 74 | ||| @node The thing we are querying. 75 | getNodeValue : (test : XPath ty' (TEST b)) 76 | -> (convErr : XPathError -> a) 77 | -> (qstr : String) 78 | -> (node : Document ty) 79 | -> {auto prfV : ValidNode ty} 80 | -> {auto prf : CanQuery ty} 81 | -> Either a String 82 | getNodeValue test convErr qstr doc = do 83 | res <- getNodeValues test convErr qstr doc 84 | case res of 85 | Nil => Left (convErr $ SingletonError (qstr)) 86 | (x::_) => Right x 87 | 88 | ||| Use XPath to get the values for a named attribute in a node satisfying the 89 | ||| given Query 90 | ||| 91 | ||| @name The name of the attribute. 92 | ||| @convErr Convert XPathError to a local error type. 93 | ||| @qstr The query to run. 94 | ||| @node The thing we are querying. 95 | getNamedAttrs : (name : String) 96 | -> (convErr : XPathError -> a) 97 | -> (qstr : String) 98 | -> (node : Document ty) 99 | -> {auto prfV : ValidNode ty} 100 | -> {auto prf : CanQuery ty} 101 | -> Either a (List String) 102 | getNamedAttrs name convErr qstr doc = getNodeValues (Attr name) convErr qstr doc 103 | 104 | ||| Use XPath to get the *first* value for a named attribute in a node 105 | ||| satisfying the given Query 106 | ||| 107 | ||| @name The name of the attribute. 108 | ||| @convErr Convert XPathError to a local error type. 109 | ||| @qstr The query to run. 110 | ||| @node The thing we are querying. 111 | getNamedAttr : (name : String) 112 | -> (convErr : XPathError -> a) 113 | -> (qstr : String) 114 | -> (node : Document ty) 115 | -> {auto prfV : ValidNode ty} 116 | -> {auto prf : CanQuery ty} 117 | -> Either a String 118 | getNamedAttr name convErr qstr doc = getNodeValue (Attr name) convErr qstr doc 119 | 120 | ||| Use XPath to get the text values for the nodes satisfying the 121 | ||| given Query 122 | ||| 123 | ||| @convErr Convert XPathError to a local error type. 124 | ||| @qstr The query to run. 125 | ||| @node The thing we are querying. 126 | getTextNodes : (convErr : XPathError -> a) 127 | -> (qstr : String) 128 | -> (node : Document ty) 129 | -> {auto prfV : ValidNode ty} 130 | -> {auto prf : CanQuery ty} 131 | -> Either a (List String) 132 | getTextNodes convErr qstr doc = getNodeValues Text convErr qstr doc 133 | 134 | ||| Use XPath to get the text value for the first node that satisfies 135 | ||| the given Query 136 | ||| 137 | ||| @convErr Convert XPathError to a local error type. 138 | ||| @qstr The query to run. 139 | ||| @node The thing we are querying. 140 | getTextNode : (convErr : XPathError -> a) 141 | -> (qstr : String) 142 | -> (node : Document ty) 143 | -> {auto prfV : ValidNode ty} 144 | -> {auto prf : CanQuery ty} 145 | -> Either a String 146 | getTextNode convErr qstr doc = getNodeValue Text convErr qstr doc 147 | 148 | ||| Use XPath to get the CData values for the nodes satisfying the 149 | ||| given Query 150 | ||| 151 | ||| @convErr Convert XPathError to a local error type. 152 | ||| @qstr The query to run. 153 | ||| @node The thing we are querying. 154 | getCDataNodes : (convErr : XPathError -> a) 155 | -> (qstr : String) 156 | -> (node : Document ty) 157 | -> {auto prf : CanQuery ty} 158 | -> {auto prfV : ValidNode ty} 159 | -> Either a (List String) 160 | getCDataNodes convErr qstr doc = getNodeValues CData convErr qstr doc 161 | 162 | ||| Use XPath to get the CData value for the first node that satisfies 163 | ||| the given Query 164 | ||| 165 | ||| @convErr Convert XPathError to a local error type. 166 | ||| @qstr The query to run. 167 | ||| @node The thing we are querying. 168 | getCDataNode : (convErr : XPathError -> a) 169 | -> (qstr : String) 170 | -> (node : Document ty) 171 | -> {auto prfV : ValidNode ty} 172 | -> {auto prf : CanQuery ty} 173 | -> Either a String 174 | getCDataNode convErr qstr doc = getNodeValue CData convErr qstr doc 175 | 176 | -- --------------------------------------------------------------------- [ EOF ] 177 | -------------------------------------------------------------------------------- /XML/Parser.idr: -------------------------------------------------------------------------------- 1 | -- -------------------------------------------------------------- [ Parser.idr ] 2 | -- Module : XML.Parser 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- 6 | -- A DOM-based XML parser. 7 | -- --------------------------------------------------------------------- [ EOH ] 8 | module XML.Parser 9 | 10 | import public Text.Lexer 11 | import public Text.Parser 12 | 13 | import public Commons.Text.Lexer.Run 14 | import public Commons.Text.Parser.Support 15 | import public Commons.Text.Parser.Run 16 | 17 | import XML.Lexer 18 | import XML.DOM 19 | 20 | %access private 21 | %default total 22 | 23 | -- --------------------------------------------------------------- [ Utilities ] 24 | 25 | public export 26 | Parser : (a : Type) -> Type 27 | Parser = Rule Token 28 | 29 | ParserE : (a : Type) -> Type 30 | ParserE = RuleEmpty Token 31 | 32 | eoi : RuleEmpty Token () 33 | eoi = eoi isEOI 34 | 35 | where 36 | isEOI : Token -> Bool 37 | isEOI EndInput = True 38 | isEOI _ = False 39 | 40 | struct : String -> Parser () 41 | struct str = 42 | match ("Expected Symbol '" ++ str ++ "'") 43 | () 44 | (Struct str) 45 | 46 | isWord : String -> Parser () 47 | isWord str = 48 | match ("Expected Symbol '" ++ str ++ "'") 49 | () 50 | (Word str) 51 | 52 | isText : String -> Parser () 53 | isText str = 54 | match ("Expected Text '" ++ str ++ "'") 55 | () 56 | (Text str) 57 | 58 | isLit : String -> Parser () 59 | isLit str = 60 | match ("Expected Lit '" ++ str ++ "'") 61 | () 62 | (StringLit ("\"" ++ str ++ "\"")) 63 | 64 | isSymbol : String -> Parser () 65 | isSymbol str = 66 | match ("Expected Symbol '" ++ str ++ "'") 67 | () 68 | (Symbol str) 69 | 70 | entity : Parser String 71 | entity = terminalF "Expected entity" 72 | (\x => case tok x of 73 | (Entity s) => Just s 74 | _ => Nothing) 75 | 76 | symbol : Parser String 77 | symbol = terminalF "Expected symbol" 78 | (\x => case tok x of 79 | (Symbol s) => Just s 80 | _ => Nothing) 81 | 82 | word : Parser String 83 | word = terminalF "Expected word" 84 | (\x => case tok x of 85 | (Word s) => Just s 86 | _ => Nothing) 87 | 88 | textStr : Parser String 89 | textStr = terminalF "Expected text" 90 | (\x => case tok x of 91 | (Text s) => Just s 92 | _ => Nothing) 93 | 94 | commentStr : Parser String 95 | commentStr = terminalF "Expected comment" 96 | (\x => case tok x of 97 | (Comment s) => Just s 98 | _ => Nothing) 99 | 100 | cdataStr : Parser String 101 | cdataStr = terminalF "Expected doc" 102 | (\x => case tok x of 103 | (CData s) => 104 | let s' = substr 9 (length s) s in 105 | let s'' = substr 3 (length s') (reverse s') 106 | in Just (reverse s'') 107 | 108 | _ => Nothing) 109 | 110 | strLit : Parser String 111 | strLit = terminalF "Expected string literal" 112 | (\x => case tok x of 113 | StringLit s => Just (fst $ span (not . (==) '"') s) 114 | _ => Nothing) 115 | 116 | kvpair : Parser a -> Parser b -> Parser (a, b) 117 | kvpair key value = do 118 | k <- key 119 | isSymbol "=" 120 | v <- value 121 | pure (k,v) 122 | 123 | kvpair' : String -> Parser b -> Parser b 124 | kvpair' key value = do 125 | isWord key 126 | isSymbol "=" 127 | v <- value 128 | pure v 129 | 130 | angles : Parser a -> Parser a 131 | angles = between (struct "<") (struct ">") 132 | 133 | -- ------------------------------------------------------------------- [ Utils ] 134 | 135 | 136 | qname : Parser $ Document QNAME 137 | qname = do 138 | pre <- optional $ (word <* isSymbol ":") 139 | name <- word 140 | pure (mkQName name Nothing pre) 141 | 142 | 143 | attr : Parser (Document QNAME, String) 144 | attr = do 145 | res <- kvpair qname strLit 146 | pure (fst res, snd res) 147 | 148 | elemStart : Parser (Document QNAME, Document QNAME, (List (Document QNAME, String))) 149 | elemStart = do 150 | struct "<" 151 | qn <- qname 152 | ns <- optional $ kvpair' "xmlns" strLit 153 | as <- optional $ some attr 154 | pure (qn, setNameSpace ns qn, fromMaybe Nil as) 155 | 156 | elemEnd : Document QNAME -> Parser () 157 | elemEnd n = angles (struct "/" *> isValid) 158 | where 159 | isValid : Parser () 160 | isValid = do 161 | seen <- qname 162 | if (assert_total $ eqDoc n seen) 163 | then pure () 164 | else fail "Malformed" 165 | 166 | -- ------------------------------------------------------------------- [ Nodes ] 167 | 168 | export 169 | comment : Parser $ Document COMMENT 170 | comment = map mkComment commentStr 171 | 172 | export 173 | cdata : Parser (Document CDATA) 174 | cdata = map mkCData cdataStr 175 | 176 | text : Parser (Document TEXT) 177 | text = map (\xs => mkText (concat xs)) $ some text' 178 | where 179 | text' : Parser String 180 | text' = entity 181 | <|> symbol 182 | <|> word 183 | <|> textStr 184 | 185 | export 186 | instruction : Parser $ Document INSTRUCTION 187 | instruction = do 188 | struct "<" 189 | isSymbol "?" 190 | t <- word 191 | d <- some (kvpair word strLit) -- @TODO make proper URL parser 192 | isSymbol "?" 193 | struct ">" 194 | pure (mkInstruction t d) 195 | 196 | export 197 | empty : Parser (Document ELEMENT) 198 | empty = do 199 | start <- elemStart 200 | struct "/" 201 | struct ">" 202 | pure (mkElement (fst $ snd start) (snd $ snd start) Nil) 203 | 204 | private 205 | buildNodeList : List (ty ** prf : ValidNode ty ** Document ty) 206 | -> (ts ** prfs ** NodeList ts prfs) 207 | buildNodeList [] = ([] ** [] ** []) 208 | buildNodeList ((ty ** prf ** node) :: xs) = 209 | let (ts ** prfs ** nodes) = buildNodeList xs 210 | in (ty :: ts ** prf :: prfs ** node :: nodes) 211 | 212 | 213 | mutual 214 | 215 | export covering 216 | node : Parser $ (ty ** prf : ValidNode ty ** Document ty) 217 | node = map (\n => (COMMENT ** ValidDoc ** n)) comment 218 | <|> map (\n => (CDATA ** ValidCData ** n)) cdata 219 | <|> map (\n => (INSTRUCTION ** ValidInstr ** n)) instruction 220 | <|> map (\n => (ELEMENT ** ValidElem ** n)) empty 221 | <|> map (\n => (ELEMENT ** ValidElem ** n)) element 222 | <|> map (\n => (TEXT ** ValidText ** n)) text 223 | 224 | covering 225 | element : Parser (Document ELEMENT) 226 | element = do 227 | start <- elemStart 228 | let qn = (fst $ snd start) 229 | let as = (snd $ snd start) 230 | struct ">" 231 | ns <- many node 232 | elemEnd (fst start) 233 | let nodes = buildNodeList ns 234 | pure (mkElement qn as (snd $ snd nodes)) 235 | 236 | %default covering 237 | 238 | isStandalone : Parser Bool 239 | isStandalone = (isLit "yes" <|> isLit "true") *> pure True 240 | 241 | notStandalone : Parser Bool 242 | notStandalone = (isLit "false" <|> isLit "no") *> pure False 243 | 244 | export 245 | xmlinfo : Parser (Document INFO) 246 | xmlinfo = do 247 | struct "<" 248 | isSymbol "?" 249 | isWord "xml" 250 | vers <- kvpair' "version" strLit 251 | enc <- option "UTF-8" $ kvpair' ("encoding") strLit 252 | alone <- option True $ kvpair' ("standalone") (isStandalone <|> notStandalone) 253 | isSymbol "?" 254 | struct ">" 255 | pure (mkXMLInfo vers enc alone) 256 | 257 | pubident : Parser (Document IDENT) 258 | pubident = do 259 | isWord "PUBLIC" 260 | loc <- strLit 261 | loc' <- strLit 262 | pure (mkPublicID loc loc') 263 | 264 | sysident : Parser (Document IDENT) 265 | sysident = map mkSystemID (isWord "SYSTEM" *> strLit) 266 | 267 | ident : Parser $ Document IDENT 268 | ident = pubident <|> sysident 269 | 270 | export 271 | doctype : Parser (Document DOCTYPE) 272 | doctype = do 273 | struct "<" 274 | isSymbol "!" 275 | isWord "DOCTYPE" 276 | v <- word 277 | id <- optional ident 278 | struct ">" 279 | pure (mkDocType v id) 280 | 281 | 282 | xmlSnippet : Parser $ Document ELEMENT 283 | xmlSnippet = (element <|> empty) 284 | 285 | export 286 | parseXMLSnippet : (str : String) -> Either (Run.ParseError Token) (Document ELEMENT) 287 | parseXMLSnippet = parseString XMLLexer xmlSnippet 288 | 289 | export 290 | xmldoc : Parser $ Document DOCUMENT 291 | xmldoc = do 292 | info <- xmlinfo 293 | dtype <- optional doctype 294 | is <- many instruction 295 | doc <- optional comment 296 | root <- element -- Add check if docttype exists for name of root element 297 | pure $ mkDocument info dtype is doc root 298 | 299 | export 300 | parseXMLDoc : (doc : String) 301 | -> (Either (Run.ParseError Token) (Document DOCUMENT)) 302 | parseXMLDoc = parseString XMLLexer xmldoc 303 | 304 | 305 | export 306 | parseXMLDocFile : (fname : String) 307 | -> IO (Either (Run.ParseError Token) (Document DOCUMENT)) 308 | parseXMLDocFile = parseFile XMLLexer xmldoc 309 | 310 | -- --------------------------------------------------------------------- [ EOF ] 311 | -------------------------------------------------------------------------------- /XML/Test/NotWellFormed.idr: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------- [ NotWellFormed.idr ] 2 | -- Module : NotWellFormed.idr 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- --------------------------------------------------------------------- [ EOH ] 6 | ||| Tests taken from [here](http://www.jclark.com/xml/). 7 | module XML.Test.NotWellFormed 8 | 9 | import Test.Unit 10 | 11 | import Commons.Data.Location 12 | import Commons.Text.Parser.Test 13 | 14 | import XML.Lexer 15 | import XML.Parser 16 | import XML.DOM 17 | import XML.Serialise 18 | 19 | showParseError : Run.ParseError Token -> String 20 | showParseError (FError e) = show e 21 | showParseError (PError e) = unlines [maybe "" show (location e), error e] 22 | showParseError (LError (MkLexFail l i)) = unlines [show l, show i] 23 | 24 | export 25 | runTests : IO () 26 | runTests = do 27 | putStrLn "=> Not WellFormed" 28 | 29 | runTests [ 30 | runParseTest showParseError $ parseFail "Not Well Formed 1" (parseXMLDoc) " " 31 | , runParseTest showParseError $ parseFail "Not Well Formed 2" (parseXMLDoc) " " 32 | 33 | , runParseTest showParseError $ parseFail "Not Well Formed 3" (parseXMLDoc) " " 34 | 35 | , runParseTest showParseError $ parseFail "Not Well Formed 4" (parseXMLDoc) " " 36 | , runParseTest showParseError $ parseFail "Not Well Formed 5" (parseXMLDoc) " " 37 | , runParseTest showParseError $ parseFail "Not Well Formed 6" (parseXMLDoc) " " 38 | , runParseTest showParseError $ parseFail "Not Well Formed 7" (parseXMLDoc) " " 39 | 40 | , runParseTest showParseError $ parseFail "Not Well Formed 8" (parseXMLDoc) " " 41 | , runParseTest showParseError $ parseFail "Not Well Formed 9" (parseXMLDoc) " " 42 | , runParseTest showParseError $ parseFail "Not Well Formed 10" (parseXMLDoc) " " 43 | 44 | , runParseTest showParseError $ parseFail "Not Well Formed 11" (parseXMLDoc) " " 45 | , runParseTest showParseError $ parseFail "Not Well Formed 12" (parseXMLDoc) " " 46 | , runParseTest showParseError $ parseFail "Not Well Formed 13" (parseXMLDoc) " " 47 | 48 | , runParseTest showParseError $ parseFail "Not Well Formed 14" (parseXMLSnippet) " " 49 | , runParseTest showParseError $ parseFail "Not Well Formed 15" (parseXMLSnippet) " <.doc> " 50 | , runParseTest showParseError $ parseFail "Not Well Formed 16" (parseXMLSnippet) "" 51 | , runParseTest showParseError $ parseFail "Not Well Formed 17" (parseXMLSnippet) "" 52 | , runParseTest showParseError $ parseFail "Not Well Formed 18" (parseXMLSnippet) "" 53 | 54 | , runParseTest showParseError $ parseFail "Not Well Formed 19" (parseXMLSnippet) "" 55 | 56 | , runParseTest showParseError $ parseFail "Not Well Formed 20" (parseXMLSnippet) "& no refc" 57 | , runParseTest showParseError $ parseFail "Not Well Formed 21" (parseXMLSnippet) "&.entity;" 58 | , runParseTest showParseError $ parseFail "Not Well Formed 22" (parseXMLSnippet) "&#RE;" 59 | , runParseTest showParseError $ parseFail "Not Well Formed 23" (parseXMLSnippet) "A & B" 60 | 61 | , runParseTest showParseError $ parseFail "Not Well Formed 24" (parseXMLSnippet) "" 62 | , runParseTest showParseError $ parseFail "Not Well Formed 25" (parseXMLSnippet) "" 63 | , runParseTest showParseError $ parseFail "Not Well Formed 26" (parseXMLSnippet) "" 64 | 65 | , runParseTest showParseError $ parseFail "Not Well Formed 27" (parseXMLSnippet) "\">" 66 | 67 | , runParseTest showParseError $ parseFail "Not Well Formed 28" (parseXMLSnippet) "" 68 | , runParseTest showParseError $ parseFail "Not Well Formed 29" (parseXMLSnippet) "" 69 | , runParseTest showParseError $ parseFail "Not Well Formed 30" (parseXMLSnippet) "" 70 | , runParseTest showParseError $ parseFail "Not Well Formed 31" (parseXMLSnippet) "" 71 | , runParseTest showParseError $ parseFail "Not Well Formed 32" (parseXMLSnippet) "" 72 | 73 | , runParseTest showParseError $ parseFail "Not Well Formed 33" (parseXMLSnippet) "" 74 | , runParseTest showParseError $ parseFail "Not Well Formed 34" (parseXMLSnippet) "" 75 | , runParseTest showParseError $ parseFail "Not Well Formed 35" (parseXMLSnippet) "" 76 | , runParseTest showParseError $ parseFail "Not Well Formed 36" (parseXMLSnippet) "" 77 | 78 | , runParseTest showParseError $ parseFail "Not Well Formed 37" (parseXMLSnippet) " <123> " 79 | , runParseTest showParseError $ parseFail "Not Well Formed 38" (parseXMLSnippet) "]]>" 80 | , runParseTest showParseError $ parseFail "Not Well Formed 39" (parseXMLSnippet) "]]]>" 81 | , runParseTest showParseError $ parseFail "Not Well Formed 40" (parseXMLSnippet) " " 108 | , runParseTest showParseError $ parseFail "Not Well Formed 59" (parseXMLSnippet) " " 109 | , runParseTest showParseError $ parseFail "Not Well Formed 60" (parseXMLSnippet) "" 110 | , runParseTest showParseError $ parseFail "Not Well Formed 61" (parseXMLSnippet) " " 111 | , runParseTest showParseError $ parseFail "Not Well Formed 62" (parseXMLSnippet) "&foo;" 112 | , runParseTest showParseError $ parseFail "Not Well Formed 63" (parseXMLSnippet) "" 113 | , runParseTest showParseError $ parseFail "Not Well Formed 64" (parseXMLSnippet) "X" 114 | , runParseTest showParseError $ parseFail "Not Well Formed 65" (parseXMLSnippet) " " 115 | , runParseTest showParseError $ parseFail "Not Well Formed 66" (parseXMLSnippet) " " 116 | , runParseTest showParseError $ parseFail "Not Well Formed 67" (parseXMLSnippet) " " 117 | 118 | , runParseTest showParseError $ parseFail "Not Well Formed 68" (parseXMLSnippet) " " 119 | , runParseTest showParseError $ parseFail "Not Well Formed 69" (parseXMLSnippet) " " 120 | 121 | , runParseTest showParseError $ parseFail "Not Well Formed 70" (parseXMLSnippet) " " 122 | , runParseTest showParseError $ parseFail "Not Well Formed 71" (parseXMLSnippet) " " 123 | , runParseTest showParseError $ parseFail "Not Well Formed 72" (parseXMLSnippet) " " 124 | 125 | , runParseTest showParseError $ parseFail "Not Well Formed 73" (parseXMLSnippet) " " 126 | , runParseTest showParseError $ parseFail "Not Well Formed 74" (parseXMLSnippet) "/doc>" 127 | , runParseTest showParseError $ parseFail "Not Well Formed 75" (parseXMLSnippet) " " 128 | , runParseTest showParseError $ parseFail "Not Well Formed 76" (parseXMLSnippet) " " 129 | 130 | , runParseTest showParseError $ parseFail "Not Well Formed 77" (parseXMLSnippet) "" 131 | , runParseTest showParseError $ parseFail "Not Well Formed 78" (parseXMLSnippet) "" 132 | 133 | , runParseTest showParseError $ parseFail "Not Well Formed 79" (parseXMLSnippet) " ]> " 134 | ] 135 | -- --------------------------------------------------------------------- [ EOF ] 136 | -------------------------------------------------------------------------------- /XML/DOM.idr: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------- [ DOM.idr ] 2 | -- Module : XML.DOM 3 | -- Copyright : (c) Jan de Muijnck-Hughes 4 | -- License : see LICENSE 5 | -- 6 | -- 7 | -- --------------------------------------------------------------------- [ EOH ] 8 | module XML.DOM 9 | 10 | import public Data.DList 11 | import public Data.PList 12 | import public Commons.Text.Display 13 | 14 | %access export 15 | %default total 16 | 17 | public export 18 | data NodeTy = DOCUMENT | ELEMENT | TEXT | CDATA | INSTRUCTION | COMMENT | QNAME | INFO | IDENT | DOCTYPE 19 | 20 | Eq NodeTy where 21 | (==) DOCUMENT DOCUMENT = True 22 | (==) ELEMENT ELEMENT = True 23 | (==) TEXT TEXT = True 24 | (==) CDATA CDATA = True 25 | (==) INSTRUCTION INSTRUCTION = True 26 | (==) COMMENT COMMENT = True 27 | (==) QNAME QNAME = True 28 | (==) INFO INFO = True 29 | (==) IDENT IDENT = True 30 | (==) DOCTYPE DOCTYPE = True 31 | (==) _ _ = False 32 | 33 | public export 34 | data ValidNode : NodeTy -> Type where 35 | ValidElem : ValidNode ELEMENT 36 | ValidCData : ValidNode CDATA 37 | ValidText : ValidNode TEXT 38 | ValidDoc : ValidNode COMMENT 39 | ValidInstr : ValidNode INSTRUCTION 40 | 41 | data Document : NodeTy -> Type where 42 | MkDocument : (info : Document INFO) 43 | -> (doctype : Maybe $ Document DOCTYPE) 44 | -> (instructions : List (Document INSTRUCTION)) 45 | -> (comment : Maybe (Document COMMENT)) 46 | -> (root : Document ELEMENT) 47 | -> Document DOCUMENT 48 | 49 | XMLInfo : (version : String) 50 | -> (encoding : String) 51 | -> (standalone : Bool) 52 | -> Document INFO 53 | 54 | DocType : (name : String) 55 | -> (ident : Maybe $ Document IDENT) 56 | -> Document DOCTYPE 57 | 58 | SystemID : (ident : String) -> Document IDENT 59 | PublicID : (ident : String) -> (ident_sys : String) -> Document IDENT 60 | 61 | QName : (name : String) 62 | -> (nspace : Maybe String) 63 | -> (nprefix : Maybe String) 64 | -> Document QNAME 65 | 66 | 67 | Element : (qName : Document QNAME) 68 | -> (attributes : List (Document QNAME, String)) 69 | -> (children : PList NodeTy Document ValidNode ts prfs) 70 | -> Document ELEMENT 71 | 72 | Comment : (comment : String) -> Document COMMENT 73 | 74 | Text : (text : String) -> Document TEXT 75 | 76 | CData : (cdata : String) -> Document CDATA 77 | 78 | Instruction : (name : String) 79 | -> (attributes : List (String, String)) 80 | -> Document INSTRUCTION 81 | 82 | -- ---------------------------------------------------------------------- [ Eq ] 83 | 84 | private 85 | maybeEq : (Document a -> Document b -> Bool) 86 | -> Maybe (Document a) 87 | -> Maybe (Document b) 88 | -> Bool 89 | maybeEq _ Nothing Nothing = True 90 | maybeEq f (Just x) (Just y) = f x y 91 | maybeEq _ _ _ = False 92 | 93 | partial 94 | eqDoc : Document a -> Document b -> Bool 95 | eqDoc (MkDocument iA dA inA cA rA) (MkDocument iB dB inB cB rB) = 96 | eqDoc iA iB 97 | && maybeEq eqDoc dA dB 98 | && (and (zipWith (\x, y => eqDoc x y) inA inB)) 99 | && maybeEq eqDoc cA cB 100 | && eqDoc rA rB 101 | 102 | eqDoc (XMLInfo vA eA sA) (XMLInfo vB eB sB) = vA == vB && eA == eB && sA == sB 103 | 104 | eqDoc (DocType nA iA) (DocType nB iB) = nA == nB && maybeEq eqDoc iA iB 105 | 106 | eqDoc (SystemID x) (SystemID y) = x == y 107 | 108 | eqDoc (PublicID x xloc) (PublicID y yloc) = x == y && xloc == yloc 109 | 110 | eqDoc (QName x xs _) (QName y ys _) = x == y && xs == ys 111 | 112 | eqDoc (Element nA aA cA) (Element nB aB cB) = 113 | eqDoc nA nB 114 | && (and (zipWith (\(a,b), (x,y) => eqDoc a x && b == y) aA aB)) 115 | && eqPList eqDoc cA cB 116 | 117 | eqDoc (Comment a) (Comment b) = a == b 118 | 119 | eqDoc (Text a) (Text b) = a == b 120 | eqDoc (CData a) (CData b) = a == b 121 | eqDoc (Instruction at ad) (Instruction bt bd) = at == bt && ad == ad 122 | eqDoc _ _ = False 123 | 124 | 125 | 126 | -- -------------------------------------------------------------------- [ Show ] 127 | 128 | partial 129 | Show (Document a) where 130 | show (MkDocument info doctype instructions comment root) = 131 | unwords ["[MkDocument" 132 | , show info 133 | , show doctype 134 | , show instructions 135 | , show comment 136 | , show root 137 | ,"]" 138 | ] 139 | show (XMLInfo version encoding standalone) = 140 | unwords ["[XMLInfo" 141 | , show version 142 | , show encoding 143 | , show standalone 144 | , "]" 145 | ] 146 | show (DocType name ident) = 147 | unwords ["[DocType" 148 | , show name 149 | , show ident 150 | , "]" 151 | ] 152 | show (SystemID ident) = unwords ["SystemID", show ident] 153 | 154 | show (PublicID ident loc) = unwords ["PublicID", show ident, show loc] 155 | 156 | show (QName name nspace nprefix) = 157 | unwords ["[QName" 158 | , show name 159 | , show nspace 160 | , show nprefix 161 | , "]" 162 | ] 163 | 164 | show (Element qName attributes children) = 165 | unwords ["[Element " 166 | , show qName 167 | , show attributes 168 | , showPList show children 169 | , "]" 170 | ] 171 | 172 | show (Comment comment) = unwords ["[Comment ", show comment, "]"] 173 | show (Text text) = unwords ["[Text", show text, "]"] 174 | show (CData cdata) = unwords ["[CData", show cdata, "]"] 175 | 176 | show (Instruction name attributes) = 177 | unwords ["[Instruction" 178 | , show name 179 | , show attributes 180 | ,"]" 181 | ] 182 | 183 | partial 184 | displayDoc : Document a -> String 185 | displayDoc (MkDocument info doctype instructions comment root) = 186 | unwords ["[MkDocument" 187 | , displayDoc info 188 | , maybe "" displayDoc doctype 189 | , unwords $ Functor.map displayDoc instructions 190 | , maybe "" displayDoc comment 191 | , displayDoc root 192 | ,"]" 193 | ] 194 | displayDoc (XMLInfo version encoding standalone) = 195 | unwords ["" 200 | ] 201 | displayDoc (DocType name ident) = 202 | unwords ["" 206 | ] 207 | displayDoc (SystemID ident) = ident 208 | 209 | displayDoc (PublicID ident loc) = unwords [display ident, display loc] 210 | 211 | displayDoc (QName name nspace nprefix) = 212 | concat [maybe "" display nspace 213 | , if isJust nspace then ":" else "" 214 | , display name 215 | ] 216 | 217 | displayDoc (Element qName attributes Nil) = 218 | concat [ "<" 219 | , displayDoc qName 220 | , unwords $ Functor.map (\(k,v) => concat [displayDoc k, "=", show v]) attributes 221 | , "/>" 222 | ] 223 | 224 | displayDoc (Element qName attributes children) = 225 | concat ["[Element " 226 | , "<", displayDoc qName, ">" 227 | , unwords $ Functor.map (\(k,v) => concat [displayDoc k, "=", show v]) attributes 228 | , concat $ map displayDoc children 229 | ,"" 230 | ] 231 | 232 | displayDoc (Comment comment) = unwords [""] 233 | displayDoc (Text text) = text 234 | displayDoc (CData cdata) = unwords [""] 235 | 236 | displayDoc (Instruction name attributes) = 237 | unwords ["" 241 | ] 242 | 243 | Display (Document a) where 244 | display d = assert_total $ displayDoc d -- nasty hack 245 | -- -------------------------------------------------------------------- [ Misc ] 246 | 247 | getDocElemTy : {a : NodeTy} -> Document a -> NodeTy 248 | getDocElemTy {a} _ = a 249 | 250 | 251 | public export 252 | NodeList : (types : List NodeTy) 253 | -> (prfs : DList NodeTy ValidNode types) 254 | -> Type 255 | NodeList = PList NodeTy Document ValidNode 256 | -- --------------------------------------------------------------------- [ API ] 257 | 258 | setRoot : Document ELEMENT -> Document DOCUMENT -> Document DOCUMENT 259 | setRoot newe (MkDocument info dtype ins doc e) = MkDocument info dtype ins doc newe 260 | 261 | getRoot : Document DOCUMENT -> Document ELEMENT 262 | getRoot (MkDocument info doctype instructions comment root) = root 263 | 264 | mkXMLInfo : String -> String -> Bool -> Document INFO 265 | mkXMLInfo = XMLInfo 266 | 267 | defaultXMLInfo : Document INFO 268 | defaultXMLInfo = mkXMLInfo "1.2" "UTF-8" True 269 | 270 | emptyNodeList : PList NodeTy Document ValidNode Nil Nil 271 | emptyNodeList = Nil 272 | 273 | mkSystemID : String -> Document IDENT 274 | mkSystemID = SystemID 275 | 276 | mkPublicID : String -> String -> Document IDENT 277 | mkPublicID = PublicID 278 | 279 | -- [ DocTypes ] 280 | 281 | mkDocType : String -> Maybe (Document IDENT) -> Document DOCTYPE 282 | mkDocType = DocType 283 | 284 | -- ------------------------------------------------------------- [ DOM Objects ] 285 | 286 | -- ------------------------------------------------------------------ [ QNames ] 287 | 288 | mkQName : String -> Maybe String -> Maybe String -> Document QNAME 289 | mkQName = QName 290 | 291 | namespace Simple 292 | 293 | ||| Create a local name 294 | mkQName : String -> Document QNAME 295 | mkQName n = QName n Nothing Nothing 296 | 297 | ||| Create a qualified name with a name space 298 | ||| 299 | ||| @n The name 300 | ||| @ns The name space. 301 | mkQNameNS : (n : String) -> (ns : String) -> Document QNAME 302 | mkQNameNS n ns = QName n (Just ns) Nothing 303 | 304 | ||| Create a tag with a name and a prefix 305 | ||| 306 | ||| @n The name 307 | ||| @pre The prefix 308 | mkQNamePrefix : (n : String) -> (pre : String) -> Document QNAME 309 | mkQNamePrefix n pre = QName n Nothing (Just pre) 310 | 311 | ||| Create a tag with namespace and prefix. 312 | ||| 313 | ||| @n The name 314 | ||| @pre The prefix. 315 | ||| @ns The namespace 316 | mkQNameNSPrefix : (n : String) -> (pre : String) -> (ns : String) -> Document QNAME 317 | mkQNameNSPrefix n pre ns = QName n (Just ns) (Just pre) 318 | 319 | ||| Create a prefixed qualified name, intended for use with 320 | ||| attributes. 321 | mkAttrNamePrefix : String -> String -> Document QNAME 322 | mkAttrNamePrefix n pre = QName n Nothing (Just pre) 323 | 324 | setNameSpace : Maybe String -> Document QNAME -> Document QNAME 325 | setNameSpace s (QName n _ pre) = QName n s pre 326 | 327 | -- ---------------------------------------------------------------- [ Elements ] 328 | 329 | ||| Create a element with a local qualified name. 330 | mkSimpleElement : String -> Document ELEMENT 331 | mkSimpleElement name = Element tag Nil Nil 332 | where 333 | tag : Document QNAME 334 | tag = mkQName name 335 | 336 | ||| Create a element with a Namespace. 337 | ||| 338 | ||| @n The name 339 | ||| @ns The namespace 340 | mkElementNS : (n : String) -> (ns : String) -> Document ELEMENT 341 | mkElementNS n ns = Element tag Nil Nil 342 | where 343 | tag = mkQNameNS n ns 344 | 345 | ||| Create an element with a prefix 346 | ||| 347 | ||| @n The name 348 | ||| @pre The prefix. 349 | mkElementPrefix : (n : String) -> (pre : String) -> Document ELEMENT 350 | mkElementPrefix n p = Element (mkQNamePrefix n p) Nil Nil 351 | 352 | ||| Create an element with a namespace and a prefix 353 | ||| 354 | ||| @n The name 355 | ||| @pre The prefix. 356 | ||| @ns The namespace 357 | mkElementNSPrefix : (n : String) 358 | -> (pre : String) 359 | -> (ns : String) 360 | -> Document ELEMENT 361 | mkElementNSPrefix n pre ns = Element (mkQNameNSPrefix n pre ns) Nil Nil 362 | 363 | ||| Create a key value pair 364 | mkAttribute : String -> String -> (Document QNAME, String) 365 | mkAttribute k v = (mkQName k, v) 366 | 367 | mkAttributePrefix : String -> String -> String -> (Document QNAME, String) 368 | mkAttributePrefix k p v = (mkQNamePrefix k p, v) 369 | 370 | ||| Creates a Document with an empty root node 371 | mkEmptyDocument : Document QNAME -> Maybe (Document DOCTYPE) -> Document DOCUMENT 372 | mkEmptyDocument n dtd = 373 | MkDocument defaultXMLInfo 374 | dtd 375 | Nil 376 | Nothing 377 | (Element n Nil emptyNodeList) 378 | 379 | mkSimpleDocument : Document ELEMENT -> Document DOCUMENT 380 | mkSimpleDocument root = MkDocument (defaultXMLInfo) Nothing Nil Nothing root 381 | 382 | mkDocument : (info : Document INFO) 383 | -> (doctype : Maybe $ Document DOCTYPE) 384 | -> (instructions : List (Document INSTRUCTION)) 385 | -> (comment : Maybe (Document COMMENT)) 386 | -> (root : Document ELEMENT) 387 | -> Document DOCUMENT 388 | mkDocument = MkDocument 389 | 390 | -- ----------------------------------------------------------- [ Node Creation ] 391 | 392 | ||| Create an XML Comment 393 | mkComment : String -> Document COMMENT 394 | mkComment = Comment 395 | 396 | mkCData : String -> Document CDATA 397 | mkCData = CData 398 | 399 | mkText : String -> Document TEXT 400 | mkText = Text 401 | 402 | mkInstruction : String -> List (String, String) -> Document INSTRUCTION 403 | mkInstruction = Instruction 404 | 405 | mkEmptyElement : Document QNAME -> List (Document QNAME, String) -> Document ELEMENT 406 | mkEmptyElement n as = Element n as Nil 407 | 408 | mkElement : Document QNAME -> List (Document QNAME, String) -> NodeList ts prfs -> Document ELEMENT 409 | mkElement = Element 410 | 411 | -- -------------------------------------------------------------- [ Attributes ] 412 | 413 | getAttrName : (Document QNAME, String) -> String 414 | getAttrName (QName n ns prefix', v) = n 415 | 416 | getAttrPrefix : (Document QNAME, String) -> Maybe String 417 | getAttrPrefix (QName n ns prefix', v) = prefix' 418 | 419 | getAttrValue : (Document QNAME, String) -> String 420 | getAttrValue (k,v) = v 421 | 422 | -- --------------------------------------------------------------- [ Accessors ] 423 | 424 | ||| Get the attributes of the node 425 | getAttributes : (node : Document a ) 426 | -> {auto prf : ValidNode a} 427 | -> List (Document QNAME, String) 428 | getAttributes (Element x xs y) {prf=ValidElem} = xs 429 | getAttributes node {prf} = Nil 430 | 431 | ||| Does node have attributes 432 | hasAttributes : Document a 433 | -> {auto prf : ValidNode a} 434 | -> Bool 435 | hasAttributes n {prf} = isCons (getAttributes n {prf=prf}) 436 | 437 | ||| Get the children 438 | getNodes : Document a 439 | -> {auto prf : ValidNode a} 440 | -> (ts ** prfs ** NodeList ts prfs) 441 | getNodes (Element x xs ys) {prf=ValidElem} = (_ ** _ ** ys) 442 | getNodes x {prf} = ([] ** [] ** []) 443 | 444 | ||| Does element have child nodes 445 | hasNodes : Document a 446 | -> {auto prf : ValidNode a} 447 | -> Bool 448 | hasNodes n = let (ts ** prfs ** nodes) = getNodes n 449 | in isCons nodes 450 | 451 | ||| Get node name 452 | ||| http://docs.oracle.com/javase/7/docs/api/org/w3c/dom/Node.html 453 | getNodeName : Document a 454 | -> {auto prf : ValidNode a} 455 | -> String 456 | getNodeName (Element (QName name nspace nprefix) xs y) {prf = ValidElem} = name 457 | getNodeName (CData x) {prf = ValidCData} = "#cdata-section" 458 | getNodeName (Text x) {prf = ValidText} = "#text" 459 | getNodeName (Comment x) {prf = ValidDoc} = "#comment" 460 | getNodeName (Instruction x xs) {prf = ValidInstr} = x 461 | 462 | ||| Return the element's value 463 | getNodeValue : Document a 464 | -> {auto prf : ValidNode a} 465 | -> Maybe String 466 | getNodeValue x {prf = ValidElem} = Nothing 467 | getNodeValue (CData x) {prf = ValidCData} = Just x 468 | getNodeValue (Text x) {prf = ValidText} = Just x 469 | getNodeValue (Comment x) {prf = ValidDoc} = Just x 470 | getNodeValue (Instruction x xs) {prf = ValidInstr} = 471 | Just $ unwords $ Functor.map show xs 472 | 473 | getTag : Document ELEMENT -> Document QNAME 474 | getTag (Element n _ _) = n 475 | 476 | ||| Get tag name 477 | getTagName : Document ELEMENT -> String 478 | getTagName (Element (QName name nspace nprefix) _ _) = name 479 | 480 | ||| Return an element's prefix 481 | getTagPrefix : Document ELEMENT -> Maybe String 482 | getTagPrefix (Element (QName name nspace nprefix) _ _) = nprefix 483 | 484 | ||| Return an element's namespace 485 | getTagNS : Document ELEMENT -> Maybe String 486 | getTagNS (Element (QName name nspace nprefix) _ _ ) = nspace 487 | 488 | 489 | ||| Get value for a given attribute 490 | getAttribute : String -> Document ELEMENT -> Maybe String 491 | getAttribute key (Element x xs y) = 492 | lookupBy cmpQName (mkQName key) xs 493 | where 494 | cmpQName (QName a _ _) (QName b _ _) = a == b 495 | 496 | ||| Remove first occurance of attribute. 497 | removeAttribute : String -> Document ELEMENT -> Document ELEMENT 498 | removeAttribute key (Element n as ns) = Element n attrs' ns 499 | where 500 | cmpQNameKVPair : (Document QNAME, String) 501 | -> (Document QNAME, String) 502 | -> Bool 503 | cmpQNameKVPair (QName a _ _, b) (QName x _ _, y) = a == x 504 | 505 | attrs' : List (Document QNAME, String) 506 | attrs' = deleteBy cmpQNameKVPair 507 | (mkQName key, "") 508 | (as) 509 | 510 | ||| Set first occurance of atttribute to new value. 511 | setAttribute : (key : String) 512 | -> (value : String) 513 | -> Document ELEMENT 514 | -> Document ELEMENT 515 | setAttribute k v e@(Element n as ns) = Element n (newAS e) ns 516 | where 517 | newAS : Document ELEMENT -> List (Document QNAME, String) 518 | newAS e = mkAttribute k v :: getAttributes (removeAttribute k e) 519 | 520 | 521 | -- ------------------------------------------------------------- [ Element Ops ] 522 | 523 | ContainsChild : (child : Document a) 524 | -> (node : NodeList ts prfs) 525 | -> (prfI : Elem a ts) 526 | -> (prfP : DElem NodeTy ValidNode prf prfs prfI) 527 | -> Type 528 | ContainsChild c n prfI prfP {a} {prf} = 529 | Elem NodeTy Document ValidNode a c prf n prfI prfP 530 | 531 | data HasElem : (elem : Document a) 532 | -> (prf : ValidNode a) 533 | -> (node : Document ELEMENT) 534 | -> Type 535 | where 536 | HasElemProof : (prf : ContainsChild elem children prfI prfP) 537 | -> HasElem elem vnode (Element n as children) 538 | 539 | infixl 2 <++> -- Append Child 540 | infixl 2 <--> -- Remove Child 541 | infixl 2 <=> -- Add Text Node 542 | infixl 2 <+=> -- Create and add text node 543 | 544 | private 545 | appendToNode : Document a 546 | -> Document ELEMENT 547 | -> (prf : ValidNode a) 548 | -> Document ELEMENT 549 | appendToNode c (Element n as ns) prf = Element n as (add c ns) 550 | 551 | private 552 | removeFromNodeList : (elem : Document a) 553 | -> (nodes : NodeList ts prfs) 554 | -> {auto idx : Elem a ts} 555 | -> {auto vprf : DElem NodeTy ValidNode prf prfs idx} 556 | -> NodeList (dropElem ts idx) (dropElem prfs vprf) 557 | removeFromNodeList elem nodes {idx} {vprf} = delete' elem nodes idx vprf 558 | 559 | private 560 | removeFromNode : (elem : Document a) 561 | -> (node : Document ELEMENT) 562 | -> (vnode : ValidNode a) 563 | -> (prf : HasElem elem vnode node) 564 | -> Document ELEMENT 565 | removeFromNode c (Element n as ns {ts = ts}) vnode (HasElemProof prf) = 566 | Element n as (dropElem ns prf) 567 | 568 | ||| Set Value 569 | addText : String -> Document ELEMENT -> Document ELEMENT 570 | addText s e = appendToNode (Text s) e ValidText 571 | 572 | -- -------------------------------------------------------------------- [ Ops ] 573 | 574 | ||| Append 575 | (<++>) : Document ELEMENT 576 | -> Document a 577 | -> {auto prf : ValidNode a} 578 | -> Document ELEMENT 579 | (<++>) p c {prf} = appendToNode c p prf 580 | 581 | ||| Remove 582 | (<-->) : (node : Document ELEMENT) 583 | -> (elem : Document a) 584 | -> {auto prfV : ValidNode a} 585 | -> {auto prfN : HasElem elem prfV node} 586 | -> Document ELEMENT 587 | (<-->) p c {prfV} {prfN} = removeFromNode c p prfV prfN 588 | 589 | ||| Add text value 590 | (<=>) : Document ELEMENT -> String -> Document ELEMENT 591 | (<=>) e s = e <++> (Text s) 592 | 593 | ||| Create and add text value 594 | (<+=>) : String -> String -> Document ELEMENT 595 | (<+=>) n v = (mkSimpleElement n) <=> v 596 | 597 | -- ------------------------------------------------------------ [ Node Queries ] 598 | 599 | namespace NodeList 600 | ||| getElements 601 | getElements : NodeList ts prfs 602 | -> List $ Document ELEMENT 603 | getElements [] = [] 604 | getElements ((::) elem {prf = ValidElem} rest) = elem :: getElements rest 605 | getElements ((::) elem {prf} rest) = getElements rest 606 | 607 | getText : NodeList ts prfs 608 | -> List $ Document TEXT 609 | getText [] = [] 610 | getText ((::) elem {prf = ValidText} rest) = elem :: getText rest 611 | getText ((::) elem {prf} rest) = getText rest 612 | 613 | getComments : NodeList ts prfs 614 | -> List $ Document COMMENT 615 | getComments Nil = Nil 616 | getComments ((::) elem {prf = ValidDoc} rest) = elem :: getComments rest 617 | getComments ((::) elem {prf} rest) = getComments rest 618 | 619 | getCData : NodeList ts prfs -> List $ Document CDATA 620 | getCData Nil = Nil 621 | getCData ((::) elem {prf = ValidCData} rest) = elem :: getCData rest 622 | getCData ((::) elem {prf} rest) = getCData rest 623 | 624 | getElements : Document ELEMENT -> List $ Document ELEMENT 625 | getElements (Element _ _ ns) = getElements ns 626 | 627 | getText : Document ELEMENT -> List $ Document TEXT 628 | getText (Element _ _ ns) = getText ns 629 | 630 | getComments : Document ELEMENT -> List $ Document COMMENT 631 | getComments (Element _ _ ns) = getComments ns 632 | 633 | getCData : Document ELEMENT -> List $ Document CDATA 634 | getCData (Element _ _ ns) = getCData ns 635 | 636 | -- --------------------------------------------------------- [ Element Queries ] 637 | 638 | public export 639 | data CanQuery : NodeTy -> Type where 640 | QueryDoc : CanQuery DOCUMENT 641 | QueryElem : CanQuery ELEMENT 642 | 643 | ||| Get the immediate child elements 644 | getChildElements : Document a -> {auto prf : CanQuery a} -> List $ Document ELEMENT 645 | getChildElements (Element _ _ ns) {prf=QueryElem} = getElements ns 646 | getChildElements (MkDocument x y xs z (Element _ _ ns)) {prf=QueryDoc} = getElements ns 647 | 648 | private 649 | doTest : (eqFunc : Document QNAME -> Document QNAME -> Bool) 650 | -> (name : Document QNAME) 651 | -> (node : Document ELEMENT) 652 | -> Maybe (Document ELEMENT) 653 | doTest eqFunc name node@(Element n attrs children) = 654 | if eqFunc name n 655 | then Just node 656 | else Nothing 657 | 658 | private partial 659 | getAllElements : (node : Document ELEMENT) 660 | -> List $ Document ELEMENT 661 | getAllElements node@(Element x as Nil) = node :: Nil 662 | getAllElements node@(Element x as xs) = node :: concatMap getAllElements (getElements xs) 663 | 664 | 665 | private 666 | getElementsBy' : (func : Document ELEMENT -> Bool) 667 | -> (node : Document a) 668 | -> (prf : CanQuery a) 669 | -> List (Document ELEMENT) 670 | getElementsBy' func (MkDocument x y xs z w) QueryDoc = filter func (assert_total $ getAllElements w) 671 | getElementsBy' func node QueryElem = filter func (assert_total $ getAllElements node) 672 | 673 | 674 | getElementsBy : (func : Document ELEMENT -> Bool) 675 | -> (node : Document a) 676 | -> {auto prf : CanQuery a} 677 | -> List (Document ELEMENT) 678 | getElementsBy func node {prf} = getElementsBy' func node prf 679 | 680 | ||| Get all Elements with a given QName 681 | getElementsByQName : Document QNAME 682 | -> Document a 683 | -> {auto prf : CanQuery a} 684 | -> List $ Document ELEMENT 685 | getElementsByQName (QName x ns p) node = getElementsBy (\(Element (QName y _ _) as xs) => x == y) node 686 | -- change tp == 687 | 688 | ||| Get all Elements with a given name. This ignores prefixes and namespaces. 689 | getElementsByName : String 690 | -> Document a 691 | -> {auto prf : CanQuery a} 692 | -> List $ Document ELEMENT 693 | getElementsByName naam e = getElementsBy (\(Element (QName x _ _) _ _) => naam == x) e 694 | 695 | ||| Get All Child Elements with a given QName. 696 | getChildElementsByQName : Document QNAME 697 | -> Document a 698 | -> {auto prf : CanQuery a} 699 | -> List $ Document ELEMENT 700 | getChildElementsByQName (QName y _ _) node {prf} = 701 | filter (\(Element (QName x _ _) _ _) => x == y) (getChildElements node) -- change to == 702 | 703 | ||| Get All Child Elements with a local name 704 | getChildElementsByName : String 705 | -> Document a 706 | -> {auto prf : CanQuery a} 707 | -> List $ Document ELEMENT 708 | getChildElementsByName name node {prf} = 709 | filter (\(Element (QName x _ _) _ _) => x == name) (getChildElements node) 710 | 711 | ||| Get All child elements regardless of name. 712 | getAllChildren : Document a 713 | -> {auto prf : CanQuery a} 714 | -> List $ Document ELEMENT 715 | getAllChildren (MkDocument x y xs z w) {prf = QueryDoc} = assert_total $ getAllElements w 716 | getAllChildren node {prf = QueryElem} = assert_total $ getAllElements node 717 | 718 | -- ----------------------------------------------------------------- [ Aliases ] 719 | 720 | public export 721 | XMLDoc : Type 722 | XMLDoc = Document DOCUMENT 723 | 724 | public export 725 | XMLElem : Type 726 | XMLElem = Document ELEMENT 727 | 728 | -- --------------------------------------------------------------------- [ EOF ] 729 | --------------------------------------------------------------------------------