Verified Commit 3af7dacb authored by Steffen Michels's avatar Steffen Michels Committed by Camil Staps

add support for XML CDATA & named character entity references

parent e0ddb50e
Pipeline #29738 passed with stage
in 2 minutes and 58 seconds
...@@ -14,7 +14,7 @@ test-nightly: ...@@ -14,7 +14,7 @@ test-nightly:
image: "camilstaps/clean:nightly" image: "camilstaps/clean:nightly"
script: script:
- COCLPATH=./compiler make -C tests/linux64 run - COCLPATH=./compiler make -C tests/linux64 run
- cleantest -r testproperties --options '-IL;Dynamics;-d;src/libraries/OS-Independent;-P;OutputTestEvents;-T;Tests 100000;-T;MaxStringLength 500;-C;-h;-C;100m;-r' --junit junit.xml - cleantest -r testproperties --options '-IL;Dynamics;-d;src/libraries/OS-Independent;-P;OutputTestEvents;-T;Tests 100000;-T;MaxStringLength 500;-T;Bent;-C;-h;-C;100m;-r' --junit junit.xml
artifacts: artifacts:
paths: paths:
- junit.xml - junit.xml
......
definition module Data.Error definition module Data.Error
from StdOverloaded import class ==
from Data.Functor import class Functor from Data.Functor import class Functor
from Control.Monad import class Monad from Control.Monad import class Monad
from Control.Applicative import class pure, class <*>, class Applicative from Control.Applicative import class pure, class <*>, class Applicative
...@@ -23,7 +24,7 @@ instance Functor (MaybeError a) ...@@ -23,7 +24,7 @@ instance Functor (MaybeError a)
instance pure (MaybeError a) instance pure (MaybeError a)
instance <*> (MaybeError a) instance <*> (MaybeError a)
instance Monad (MaybeError a) instance Monad (MaybeError a)
instance == (MaybeError a b) | == a & == b
derive gEq MaybeError derive gEq MaybeError
/** /**
......
implementation module Data.Error implementation module Data.Error
import StdMisc import StdMisc
import Data.Functor, Data.Maybe, Data.GenEq import Data.Functor, Data.Maybe, Data.GenEq
import Control.Monad import Control.Monad
import Control.Applicative import Control.Applicative
instance Functor (MaybeError a) instance Functor (MaybeError a)
where where
fmap f (Ok x) = Ok (f x) fmap f (Ok x) = Ok (f x)
fmap f (Error x) = Error x fmap f (Error x) = Error x
instance pure (MaybeError a) instance pure (MaybeError a)
where where
pure x = Ok x pure x = Ok x
instance <*> (MaybeError a) instance <*> (MaybeError a)
where where
(<*>) (Error e) _ = Error e (<*>) (Error e) _ = Error e
(<*>) (Ok f) r = fmap f r (<*>) (Ok f) r = fmap f r
instance Monad (MaybeError e) where instance Monad (MaybeError e) where
bind (Error l) _ = Error l bind (Error l) _ = Error l
bind (Ok r) k = k r bind (Ok r) k = k r
derive gEq MaybeError instance == (MaybeError a b) | == a & == b where
== (Ok x) y = case y of
isOk :: !(MaybeError a b) -> Bool Ok y = x == y
isOk (Ok _) = True _ = False
isOk (Error _) = False == (Error x) y = case y of
Error y = x == y
isError :: !(MaybeError a b) -> Bool _ = False
isError (Ok _) = False
isError (Error _) = True derive gEq MaybeError
fromOk :: !(MaybeError .a .b) -> .b isOk :: !(MaybeError a b) -> Bool
fromOk (Ok b) = b isOk (Ok _) = True
fromOk (Error _) = abort "Data.Error.fromOk: argument is Error" isOk (Error _) = False
fromError :: !(MaybeError .a .b) -> .a isError :: !(MaybeError a b) -> Bool
fromError (Error a) = a isError (Ok _) = False
fromError (Ok _) = abort "Data.Error.fromError: argument is Ok" isError (Error _) = True
liftError :: !(MaybeError .a .b) -> (MaybeError .a .c) fromOk :: !(MaybeError .a .b) -> .b
liftError (Error a) = Error a fromOk (Ok b) = b
liftError (Ok _) = abort "Data.Error.liftError: argument is Ok" fromOk (Error _) = abort "Data.Error.fromOk: argument is Error"
mb2error :: !e !(Maybe a) -> MaybeError e a fromError :: !(MaybeError .a .b) -> .a
mb2error error mbV = maybe (Error error) Ok mbV fromError (Error a) = a
fromError (Ok _) = abort "Data.Error.fromError: argument is Ok"
okSt :: *st (.a *st -> *st) !(MaybeError .e .a) -> *st
okSt st f (Error _) = st liftError :: !(MaybeError .a .b) -> (MaybeError .a .c)
okSt st f (Ok x) = f x st liftError (Error a) = Error a
liftError (Ok _) = abort "Data.Error.liftError: argument is Ok"
error2mb :: !(MaybeError e a) -> Maybe a
error2mb (Error _) = Nothing mb2error :: !e !(Maybe a) -> MaybeError e a
error2mb (Ok a) = Just a mb2error error mbV = maybe (Error error) Ok mbV
seqErrors :: !(MaybeError e a) (a -> MaybeError e b) -> MaybeError e b okSt :: *st (.a *st -> *st) !(MaybeError .e .a) -> *st
seqErrors a bfunc = case a of okSt st f (Error _) = st
Ok a = bfunc a okSt st f (Ok x) = f x st
Error e = Error e
error2mb :: !(MaybeError e a) -> Maybe a
combineErrors :: !(MaybeError e a) (MaybeError e b) (a b -> MaybeError e c) -> MaybeError e c error2mb (Error _) = Nothing
combineErrors a b combf = case a of error2mb (Ok a) = Just a
Error e = Error e
Ok a = case b of seqErrors :: !(MaybeError e a) (a -> MaybeError e b) -> MaybeError e b
Error e = Error e seqErrors a bfunc = case a of
Ok b = combf a b Ok a = bfunc a
Error e = Error e
seqErrorsSt :: !(.st -> (MaybeError e a,.st)) (a .st -> u:(MaybeError e b, .st)) !.st -> v:(MaybeError e b, !.st), [u <= v]
seqErrorsSt aop bop st combineErrors :: !(MaybeError e a) (MaybeError e b) (a b -> MaybeError e c) -> MaybeError e c
# (a,st) = aop st combineErrors a b combf = case a of
= case a of Error e = Error e
Error e = (Error e,st) Ok a = case b of
Ok a = bop a st Error e = Error e
Ok b = combf a b
combineErrorsSt :: !(.st -> (MaybeError e a, .st)) (.st -> (MaybeError e b, .st)) (a b -> MaybeError e c) !.st -> (!MaybeError e c, !.st) seqErrorsSt :: !(.st -> (MaybeError e a,.st)) (a .st -> u:(MaybeError e b, .st)) !.st -> v:(MaybeError e b, !.st), [u <= v]
combineErrorsSt aop bop combf st seqErrorsSt aop bop st
# (a,st) = aop st # (a,st) = aop st
= case a of = case a of
Error e = (Error e,st) Error e = (Error e,st)
Ok a Ok a = bop a st
# (b,st) = bop st
= case b of
Error e = (Error e, st) combineErrorsSt :: !(.st -> (MaybeError e a, .st)) (.st -> (MaybeError e b, .st)) (a b -> MaybeError e c) !.st -> (!MaybeError e c, !.st)
Ok b = (combf a b, st) combineErrorsSt aop bop combf st
# (a,st) = aop st
= case a of
Error e = (Error e,st)
Ok a
# (b,st) = bop st
= case b of
Error e = (Error e, st)
Ok b = (combf a b, st)
definition module Data.Maybe.Gast
from Data.Maybe import :: Maybe
from Gast import generic ggen, generic genShow, :: GenState
derive genShow Maybe
derive ggen Maybe
implementation module Data.Maybe.Gast
import Gast
import Data.Maybe
import Control.GenBimap
derive genShow Maybe
derive ggen Maybe
definition module Data.Maybe.GenPrint
from Data.Maybe import :: Maybe
from Text.GenPrint import generic gPrint, class PrintOutput, :: PrintState
derive gPrint Maybe
implementation module Data.Maybe.GenPrint
import Data.Maybe
import Text.GenPrint
derive gPrint Maybe
definition module Text.GenXML definition module Text.GenXML
/** /**
* This module provides data types for easy construction of XML documents and * This module provides data types for easy construction of XML documents and
* a generic printer/parser. * a generic conversion of Clean values to XML.
*
* @property-bootstrap
* import StdEnv, Data.Error, Data.Func, Text.GenXML.Gast, Text.GenXML.GenPrint
*
* derive genShow MaybeError
* derive gPrint MaybeError
* derive class Gast Maybe
*
* withMergedConsecutiveText :: !XMLDoc -> XMLDoc
* withMergedConsecutiveText (XMLDoc defaultNamespace namespaces rootNode) =
* XMLDoc defaultNamespace namespaces $ nodeWithMergedConsecutiveText rootNode
*
* nodeWithMergedConsecutiveText :: !XMLNode -> XMLNode
* nodeWithMergedConsecutiveText (XMLElem name attrs nodes) =
* XMLElem name attrs $ nodesWithMergedConsecutiveText nodes
* nodeWithMergedConsecutiveText node = node
*
* nodesWithMergedConsecutiveText :: ![XMLNode] -> [XMLNode]
* nodesWithMergedConsecutiveText [] = []
* nodesWithMergedConsecutiveText [XMLText text1, XMLText text2: rest] =
* nodesWithMergedConsecutiveText [XMLText $ text1 +++ text2: rest]
* nodesWithMergedConsecutiveText [node: rest] =
* [nodeWithMergedConsecutiveText node: nodesWithMergedConsecutiveText rest]
*/ */
import StdOverloaded, StdGeneric, Data.Either import StdOverloaded, StdGeneric, Data.Either
from Data.Maybe import :: Maybe from Data.Maybe import :: Maybe
from Data.Error import :: MaybeErrorString, :: MaybeError from Data.Error import :: MaybeErrorString, :: MaybeError
from Data.GenEq import generic gEq
:: XMLDoc = XMLDoc !(Maybe XMLURI) ![(XMLNamespacePrefix,XMLURI)] !XMLNode :: XMLDoc = XMLDoc !(Maybe XMLURI) ![(XMLNamespacePrefix,XMLURI)] !XMLNode
:: XMLNode = XMLElem !XMLQName ![XMLAttr] ![XMLNode] instance == XMLDoc
| XMLText !String derive gEq XMLDoc
/**
* A node in an XML document.
*/
:: XMLNode
= XMLElem !XMLQName ![XMLAttr] ![XMLNode] //* An element
| XMLText !String //* Character data
| XMLCData !String //* A CDATA section
derive gEq XMLNode
:: XMLAttr = XMLAttr !XMLQName !String :: XMLAttr = XMLAttr !XMLQName !String
derive gEq XMLAttr
:: XMLQName = XMLQName !(Maybe XMLNamespacePrefix) !XMLName :: XMLQName = XMLQName !(Maybe XMLNamespacePrefix) !XMLName
derive gEq XMLQName
:: XMLNamespacePrefix :== String :: XMLNamespacePrefix :== String
:: XMLURI :== String :: XMLURI :== String
:: XMLName :== String :: XMLName :== String
/** /**
* Create an XMLQName containing an unqualified name from a String * Create an XMLQName containing an unqualified name from a String.
*
* @param Unqualified name * @param Unqualified name
* @return XMLQName containing the unqualified name * @result XMLQName containing the unqualified name
*/ */
uname :: !String -> XMLQName uname :: !String -> XMLQName
/** /**
* Create an XMLQName containing a qualified name from a String * Create an XMLQName containing a qualified name from a String.
*
* @param Qualified name * @param Qualified name
* @return XMLQName containing the qualified name * @result XMLQName containing the qualified name
*/ */
qname :: !XMLNamespacePrefix !String -> XMLQName qname :: !XMLNamespacePrefix !String -> XMLQName
instance toString XMLDoc instance toString XMLDoc
/**
* The XML document corresponding to a string.
*
* @property correctness: A.doc :: XMLDoc:
* fromString (toString doc) =.= typedOk (withMergedConsecutiveText doc)
* where
* typedOk :: !XMLDoc -> MaybeErrorString XMLDoc
* typedOk doc = Ok doc
*/
instance fromString (MaybeErrorString XMLDoc) instance fromString (MaybeErrorString XMLDoc)
// generic printer // generic printer
...@@ -45,6 +95,7 @@ toXML :: !a -> XMLDoc | XMLEncode{|*|} a ...@@ -45,6 +95,7 @@ toXML :: !a -> XMLDoc | XMLEncode{|*|} a
toXMLString :: !a -> String | XMLEncode{|*|} a toXMLString :: !a -> String | XMLEncode{|*|} a
:: XMLEncodeResult :: XMLEncodeResult
generic XMLEncode a :: !a -> XMLEncodeResult generic XMLEncode a :: !a -> XMLEncodeResult
// special types for adding attributes to XML data // special types for adding attributes to XML data
......
definition module Text.GenXML.Gast
from Gast import generic ggen, generic genShow, :: GenState
from Text.GenXML import :: XMLDoc, :: XMLNode, :: XMLAttr, :: XMLQName
derive ggen XMLDoc, XMLQName, XMLNode, XMLAttr
derive genShow XMLDoc, XMLQName, XMLNode, XMLAttr
implementation module Text.GenXML.Gast
import StdEnv
import Gast
import Data.Func, Data.Functor, Data.Maybe, Data.Maybe.Gast, Data.List, Data.Bifunctor, Data.Tuple
import Text.GenXML
import Control.GenBimap
derive genShow XMLDoc, XMLQName, XMLNode, XMLAttr
derive ggen XMLNode, XMLAttr
// TODO: Generate URIs for namespaces, instead of using names.
ggen{|XMLDoc|} st =
[ XMLDoc
(unNameString <$> defaultNamespace)
(bifmap unNameString unNameString <$> namespaces)
(XMLElem rootName rootAttrs rootChildren)
\\ (defaultNamespace, namespaces, rootName, rootAttrs, rootChildren) <- ggen{|*|} st
]
ggen{|XMLQName|} st = [XMLQName (unNameString <$> namespace) (unNameString name) \\ (namespace, name) <- ggen{|*|} st]
:: NameString =: NameString String
unNameString :: !NameString -> String
unNameString (NameString str) = str
// TODO: Also include capital letters and other valid characters.
ggen{|NameString|} _ = [NameString str \\ str <- ggenString 7 4.0 97 122 aStream | str <> ""]
definition module Text.GenXML.GenPrint
from Text.GenXML import :: XMLDoc, :: XMLNode, :: XMLAttr, :: XMLQName
from Text.GenPrint import generic gPrint, class PrintOutput, :: PrintState
derive gPrint XMLDoc, XMLQName, XMLNode, XMLAttr
implementation module Text.GenXML.GenPrint
import Data.Maybe.GenPrint
import Text.GenXML, Text.GenPrint
derive gPrint XMLDoc, XMLQName, XMLNode, XMLAttr
...@@ -13,7 +13,8 @@ CLMLIBS:=\ ...@@ -13,7 +13,8 @@ CLMLIBS:=\
-I ../../src/libraries/Platform-x86\ -I ../../src/libraries/Platform-x86\
-IL Dynamics\ -IL Dynamics\
-IL GraphCopy\ -IL GraphCopy\
-IL TCPIP -IL TCPIP\
-IL Gast
COCLPATH?=../../../compiler COCLPATH?=../../../compiler
COCLLIBS:=\ COCLLIBS:=\
...@@ -32,6 +33,7 @@ $(filter-out checktest commentstest tartest snappytest,$(BINARIES)): .FORCE ...@@ -32,6 +33,7 @@ $(filter-out checktest commentstest tartest snappytest,$(BINARIES)): .FORCE
$(CLM) $(CLMLIBS) -PABC StdMaybe $(CLM) $(CLMLIBS) -PABC StdMaybe
$(CLM) $(CLMLIBS) -PABC -dynamics _SystemDynamic $(CLM) $(CLMLIBS) -PABC -dynamics _SystemDynamic
$(CLM) $(CLMLIBS) -PABC TCPIP $(CLM) $(CLMLIBS) -PABC TCPIP
$(CLM) $(CLMLIBS) -PABC Gast
$(CLM) $(CLMLIBS) $(CLMFLAGS) $@ -o $@ $(CLM) $(CLMLIBS) $(CLMFLAGS) $@ -o $@
$(filter-out run_tartest,$(RUN_BINARIES)): run_%: % $(filter-out run_tartest,$(RUN_BINARIES)): run_%: %
......
...@@ -126,6 +126,8 @@ import qualified Data.MapCollection ...@@ -126,6 +126,8 @@ import qualified Data.MapCollection
import qualified Data.Matrix import qualified Data.Matrix
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Maybe.Ord import qualified Data.Maybe.Ord
import qualified Data.Maybe.Gast
import qualified Data.Maybe.GenPrint
import qualified Data.Monoid import qualified Data.Monoid
import qualified Data.NGramIndex import qualified Data.NGramIndex
import qualified Data.OrdList import qualified Data.OrdList
...@@ -200,6 +202,8 @@ import qualified Text.GenJSON ...@@ -200,6 +202,8 @@ import qualified Text.GenJSON
import qualified Text.GenParse import qualified Text.GenParse
import qualified Text.GenPrint import qualified Text.GenPrint
import qualified Text.GenXML import qualified Text.GenXML
import qualified Text.GenXML.Gast
import qualified Text.GenXML.GenPrint
import qualified Text.HTML import qualified Text.HTML
import qualified Text.HTML.GenJSON import qualified Text.HTML.GenJSON
import qualified Text.LaTeX import qualified Text.LaTeX
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment