Support XML namespaces

madman-bob · Nov 2, 2021 · dbec8c9 · dbec8c9
1 parent 0c65c8f
commit dbec8c9
Showing 11 changed files with 122 additions and 39 deletions.
diff --git a/XML/Language/XML/Attribute.idr b/XML/Language/XML/Attribute.idr
@@ -2,17 +2,19 @@ module Language.XML.Attribute
 
 import Data.String.Parser
 
+import public Language.XML.Name
+
 public export
 record Attribute where
     constructor MkAttribute
-    name : String
+    name : QName
     value : String
 
 %name Attribute attr
 
 export
 Show Attribute where
-    show attr = "\{attr.name}=\{show attr.value}"
+    show attr = "\{show attr.name}=\{show attr.value}"
 
 export
 quotedString : Parser String
@@ -25,7 +27,7 @@ quotedString = do
 export
 attribute : Parser Attribute
 attribute = (do
-    name <- pack <$> many letter
+    name <- qName
     spaces
     ignore $ string "="
     spaces
@@ -34,7 +36,7 @@ attribute = (do
   ) <?> "XML attribute"
 
 export
-exactAttribute : String -> Parser String
+exactAttribute : QName -> Parser String
 exactAttribute expectedName = do
     MkAttribute name value <- attribute
     if name == expectedName

diff --git a/XML/Language/XML/Element.idr b/XML/Language/XML/Element.idr
@@ -7,10 +7,11 @@ import Data.String.Extra
 import Data.String.Parser
 
 import public Language.XML.Attribute
+import public Language.XML.Name
 
 public export
-data Element = EmptyElem String (List Attribute)
-             | Elem String (List Attribute) (Odd (Maybe String) Element)
+data Element = EmptyElem QName (List Attribute)
+             | Elem QName (List Attribute) (Odd (Maybe String) Element)
 
 %name Element elem
 
@@ -24,12 +25,12 @@ indentLines str = unlines $ map indent $ lines str
 export
 Show Element where
     show (EmptyElem name attrs) =
-        "<\{name}\{concat $ map (\attr => " " ++ show attr) attrs}/>"
+        "<\{show name}\{concat $ map (\attr => " " ++ show attr) attrs}/>"
     show (Elem name attrs content) =
         """
-        <\{name}\{concat $ map (\attr => " " ++ show attr) attrs}>\
+        <\{show name}\{concat $ map (\attr => " " ++ show attr) attrs}>\
         \{indentLines $ concat $ map ("\n" ++) $ catMaybes $ forget $ mapSnd (Just . show) content}\
-        </\{name}>
+        </\{show name}>
         """
 
 export
@@ -44,7 +45,7 @@ export
 element : Parser Element
 element = (do
     ignore $ string "<"
-    name <- pack <$> many letter
+    name <- qName
     attrs <- many (spaces *> attribute)
     spaces
     Nothing <- optional $ string "/>"
@@ -53,7 +54,7 @@ element = (do
 
     content <- alternating charData element
 
-    string "</\{name}" *> spaces <* string ">"
+    string "</\{show name}" *> spaces <* string ">"
 
     pure $ Elem name attrs content
   ) <?> "XML element"
diff --git a/XML/Language/XML/Name.idr b/XML/Language/XML/Name.idr
@@ -0,0 +1,53 @@
+module Language.XML.Name
+
+import Data.String.Parser
+
+public export
+data Name = MkName String
+
+%name Name name
+
+export
+Show Name where
+    show (MkName n) = n
+
+export
+Eq Name where
+    MkName n1 == MkName n2 = n1 == n2
+
+public export
+record QName where
+    constructor MkQName
+    namespacePrefix : Maybe Name
+    localPart : Name
+
+%name QName name
+
+export
+Show QName where
+    show (MkQName Nothing localPart) = show localPart
+    show (MkQName (Just namespacePrefix) localPart) = show namespacePrefix ++ ":" ++ show localPart
+
+export
+Eq QName where
+    n1 == n2 = n1.namespacePrefix == n2.namespacePrefix && n1.localPart == n2.localPart
+
+public export
+isNameStartChar : Char -> Bool
+isNameStartChar c = isAlpha c || c == '_'
+
+public export
+isNameChar : Char -> Bool
+isNameChar c = isAlphaNum c || c == '.' || c == '-' || c == '_'
+
+export
+name : Parser Name
+name = MkName <$> pack <$> [| satisfy isNameStartChar :: many (satisfy isNameChar) |]
+
+export
+qName : Parser QName
+qName = do
+    n <- name
+    Just localPart <- optional (char ':' *> name)
+        | Nothing => pure $ MkQName Nothing n
+    pure $ MkQName (Just n) localPart
diff --git a/XML/Language/XML/Prolog/XMLDecl.idr b/XML/Language/XML/Prolog/XMLDecl.idr
@@ -27,9 +27,9 @@ xmlDecl : Parser XMLDecl
 xmlDecl = (do
     ignore $ string "<?xml"
     spaces1
-    version <- exactAttribute "version"
-    encoding <- optional (spaces *> exactAttribute "encoding")
-    standalone <- case !(optional (spaces *> exactAttribute "standalone")) of
+    version <- exactAttribute $ MkQName Nothing $ MkName "version"
+    encoding <- optional (spaces *> exactAttribute (MkQName Nothing $ MkName "encoding"))
+    standalone <- case !(optional (spaces *> exactAttribute (MkQName Nothing $ MkName "standalone"))) of
           Just "yes" => pure $ Just True
           Just "no" => pure $ Just False
           Nothing => pure Nothing

diff --git a/tests/XMLDocument/Element/Element.idr b/tests/XMLDocument/Element/Element.idr
@@ -4,32 +4,32 @@ import Language.XML.Element
 
 main : IO ()
 main = do
-    printLn $ EmptyElem "br" []
-    printLn $ Elem "br" [] [Nothing]
+    printLn $ EmptyElem (MkQName Nothing (MkName "br")) []
+    printLn $ Elem (MkQName Nothing (MkName "br")) [] [Nothing]
 
-    printLn $ EmptyElem "img" [MkAttribute "align" "left", MkAttribute "src" "https://www.w3.org/Icons/w3c_home"]
-    printLn $ Elem "body" [] [Nothing, EmptyElem "hr" [], Nothing]
-    printLn $ Elem "p" [MkAttribute "class" "article"] [Just "Lorem ipsum, dolor", Elem "em" [] [Just "sit"], Just "amet"]
+    printLn $ EmptyElem (MkQName Nothing (MkName "img")) [MkAttribute (MkQName Nothing (MkName "align")) "left", MkAttribute (MkQName Nothing (MkName "src")) "https://www.w3.org/Icons/w3c_home"]
+    printLn $ Elem (MkQName Nothing (MkName "body")) [] [Nothing, EmptyElem (MkQName Nothing (MkName "hr")) [], Nothing]
+    printLn $ Elem (MkQName Nothing (MkName "p")) [MkAttribute (MkQName Nothing (MkName "class")) "article"] [Just "Lorem ipsum, dolor", Elem (MkQName Nothing (MkName "em")) [] [Just "sit"], Just "amet"]
 
-    let Right (EmptyElem "br" [], 5) = parse element "<br/>"
+    let Right (EmptyElem (MkQName Nothing (MkName "br")) [], 5) = parse element "<br/>"
         | fail => putStrLn "Error parsing XML element, got \{show fail}"
 
-    let Right (Elem "br" [] [Nothing], 9) = parse element "<br></br>"
+    let Right (Elem (MkQName Nothing (MkName "br")) [] [Nothing], 9) = parse element "<br></br>"
         | fail => putStrLn "Error parsing XML element, got \{show fail}"
 
     let Right (
             EmptyElem
-                "img"
-                [MkAttribute "align" "left", MkAttribute "src" "https://www.w3.org/Icons/w3c_home"],
+                (MkQName Nothing (MkName "img"))
+                [MkAttribute (MkQName Nothing (MkName "align")) "left", MkAttribute (MkQName Nothing (MkName "src")) "https://www.w3.org/Icons/w3c_home"],
             59
             ) = parse element #"<img align="left" src="https://www.w3.org/Icons/w3c_home"/>"#
         | fail => putStrLn "Error parsing XML element, got \{show fail}"
 
     let Right (
             Elem
-                "body"
+                (MkQName Nothing (MkName "body"))
                 []
-                [Nothing, EmptyElem "hr" [], Nothing],
+                [Nothing, EmptyElem (MkQName Nothing (MkName "hr")) [], Nothing],
             24
             ) = parse element
                 """
@@ -41,9 +41,9 @@ main = do
 
     let Right (
             Elem
-                "p"
-                [MkAttribute "class" "article"]
-                [Just "Lorem ipsum, dolor", Elem "em" [] [Just "sit"], Just "amet"],
+                (MkQName Nothing (MkName "p"))
+                [MkAttribute (MkQName Nothing (MkName "class")) "article"]
+                [Just "Lorem ipsum, dolor", Elem (MkQName Nothing (MkName "em")) [] [Just "sit"], Just "amet"],
             87
             ) = parse element
                     """

diff --git a/tests/XMLDocument/Name/Name.idr b/tests/XMLDocument/Name/Name.idr
@@ -0,0 +1,20 @@
+import Data.String.Parser
+
+import Language.XML.Name
+
+main : IO ()
+main = do
+    printLn $ MkName "body"
+    printLn $ MkQName Nothing (MkName "body")
+    printLn $ MkQName (Just $ MkName "html") (MkName "body")
+
+    let Right (MkName "html", 4) = parse name "html"
+        | fail => putStrLn "Error parsing XML name, got \{show fail}"
+
+    let Right (MkQName Nothing (MkName "html"), 4) = parse qName "html"
+        | fail => putStrLn "Error parsing XML name, got \{show fail}"
+
+    let Right (MkQName (Just $ MkName "xml") (MkName "html"), 8) = parse qName "xml:html"
+        | fail => putStrLn "Error parsing XML name, got \{show fail}"
+
+    pure ()
diff --git a/tests/XMLDocument/Name/expected b/tests/XMLDocument/Name/expected
@@ -0,0 +1,3 @@
+body
+body
+html:body
diff --git a/tests/XMLDocument/Name/run b/tests/XMLDocument/Name/run
@@ -0,0 +1,3 @@
+. ../../testutils.sh
+
+basicTest Name.idr
diff --git a/tests/XMLDocument/XMLDocument/XMLDocument.idr b/tests/XMLDocument/XMLDocument/XMLDocument.idr
@@ -7,8 +7,8 @@ main = do
     printLn $ MkXMLDocument
         (MkXMLProlog Nothing [] Nothing [])
         (Elem
-            "p"
-            [MkAttribute "class" "article"]
+            (MkQName Nothing (MkName "p"))
+            [MkAttribute (MkQName Nothing (MkName "class")) "article"]
             [Just "Lorem ipsum, dolor sit amet"])
         []
 
@@ -21,17 +21,17 @@ main = do
             (Just $ MkDocType "html" Nothing)
             [Comment " Another comment "])
         (Elem
-            "p"
-            [MkAttribute "class" "article"]
-            [Just "Lorem ipsum, dolor", Elem "em" [] [Just "sit"], Just "amet"])
+            (MkQName Nothing (MkName "p"))
+            [MkAttribute (MkQName Nothing (MkName "class")) "article"]
+            [Just "Lorem ipsum, dolor", Elem (MkQName Nothing (MkName "em")) [] [Just "sit"], Just "amet"])
         [Comment " Yet another comment "]
 
     let Right (
             MkXMLDocument
                 (MkXMLProlog Nothing [] Nothing [])
                 (Elem
-                    "p"
-                    [MkAttribute "class" "article"]
+                    (MkQName Nothing (MkName "p"))
+                    [MkAttribute (MkQName Nothing (MkName "class")) "article"]
                     [Just "Lorem ipsum, dolor sit amet"])
                 [],
             50
@@ -46,9 +46,9 @@ main = do
                     (Just $ MkDocType "html" Nothing)
                     [Comment " Another comment "])
                 (Elem
-                    "p"
-                    [MkAttribute "class" "article"]
-                    [Just "Lorem ipsum, dolor", Elem "em" [] [Just "sit"], Just "amet"])
+                    (MkQName Nothing (MkName "p"))
+                    [MkAttribute (MkQName Nothing (MkName "class")) "article"]
+                    [Just "Lorem ipsum, dolor", Elem (MkQName Nothing (MkName "em")) [] [Just "sit"], Just "amet"])
                 [Comment " Yet another comment "],
             229
             ) = parse xmlDocument

diff --git a/tests/XMLTests.idr b/tests/XMLTests.idr
@@ -14,7 +14,7 @@ miscTests = MkTestPool "Misc" [] Nothing [
 
 documentTests : TestPool
 documentTests = MkTestPool "XMLDocument" [] Nothing [
-    "Element", "XMLDocument"
+    "Element", "Name", "XMLDocument"
   ]
 
 main : IO ()

diff --git a/xml.ipkg b/xml.ipkg
@@ -9,6 +9,7 @@ modules =
     Language.XML.Attribute,
     Language.XML.Element,
     Language.XML.Misc,
+    Language.XML.Name,
     Language.XML.Prolog,
     Language.XML.Prolog.DocType,
     Language.XML.Prolog.XMLDecl