diff --git a/examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs b/examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs --- a/examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs +++ b/examples/arrows/AGentleIntroductionToHXT/PicklerExample/Baseball.hs @@ -11,7 +11,7 @@ import Data.Map (Map, fromList, toList) -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core -- Example data taken from: -- http://www.ibiblio.org/xml/books/bible/examples/05/5-1.xml @@ -115,15 +115,15 @@ main :: IO () main = do - runX ( xunpickleDocument xpSeason [ (a_validate,v_0) - , (a_trace, v_1) - , (a_remove_whitespace,v_1) - , (a_preserve_comment, v_0) + runX ( xunpickleDocument xpSeason [ withValidate no + , withTrace 1 + , withRemoveWS yes + , withPreserveComment no ] "simple2.xml" >>> processSeason >>> - xpickleDocument xpSeason [ (a_indent, v_1) + xpickleDocument xpSeason [ withIndent yes ] "new-simple2.xml" ) return () diff --git a/examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs b/examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs --- a/examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs +++ b/examples/arrows/AGentleIntroductionToHXT/SimpleExamples.hs @@ -1,14 +1,13 @@ {- | - $Id: SimpleExamples.hs,v 1.3 2006/11/17 17:16:24 hxml Exp $ - - The examples from the HXT tutorial at haskell.org "http://www.haskell.org/haskellwiki/HXT" + The examples from the HXT tutorial at haskell.org "http://www.haskell.org/haskellwiki/HXT" -} module Main where -import Text.XML.HXT.Arrow -- import HXT stuff -import Text.XML.HXT.XPath +import Text.XML.HXT.Core -- basic HXT stuff +import Text.XML.HXT.XPath -- additional XPath functions +import Text.XML.HXT.Curl -- Curl HTTP handler import Data.List -- auxiliary functions import Data.Maybe @@ -35,45 +34,54 @@ then exitWith (ExitFailure (-1)) else exitWith ExitSuccess -application :: Attributes -> String -> String -> String -> IOSArrow b Int -application al fct src dst - = readDocument al src +application :: SysConfigList -> String -> String -> String -> IOSArrow b Int +application config fct src dst + = configSysVars config -- set all global config options >>> + readDocument [] src + >>> processChildren (processRootElement fct `when` isElem) >>> - writeDocument ( (a_indent, v_1) - : (a_output_encoding, isoLatin1) - : al - ) dst + writeDocument [ withIndent yes, + withOutputEncoding isoLatin1 + ] + dst >>> getErrStatus -- | the dummy for the boring stuff of option evaluation, -- usually done with 'System.Console.GetOpt' -cmdlineOpts :: [String] -> IO (Attributes, String, String, String) +cmdlineOpts :: [String] -> IO (SysConfigList, String, String, String) cmdlineOpts argv - = return ([(a_validate, v_0),(a_parse_html, v_1)], argv!!0, argv!!1, argv!!2) + = return ( [ withValidate no + , withParseHTML yes + , withCurl [] + ] + , argv!!0 + , argv!!1 + , argv!!2 + ) -- | the processing examples examples :: [ (String, IOSArrow XmlTree XmlTree) ] examples - = [ ( "selectAllText", selectAllText ) - , ( "selectAllTextAndAltValues", selectAllTextAndAltValues ) + = [ ( "selectAllText", selectAllText ) + , ( "selectAllTextAndAltValues", selectAllTextAndAltValues ) , ( "selectAllTextAndRealAltValues", selectAllTextAndRealAltValues ) - , ( "addRefIcon", addRefIcon ) - , ( "helloWorld", helloWorld ) - , ( "helloWorld2", helloWorld2 ) - , ( "imageTable", imageTable ) - , ( "imageTable0", imageTable0 ) - , ( "imageTable1", imageTable1 ) - , ( "imageTable2", imageTable2 ) - , ( "imageTable3", imageTable3 ) - , ( "toAbsHRefs", toAbsHRefs ) - , ( "toAbsRefs", toAbsRefs ) - , ( "toAbsRefs1", toAbsRefs1 ) + , ( "addRefIcon", addRefIcon ) + , ( "helloWorld", helloWorld ) + , ( "helloWorld2", helloWorld2 ) + , ( "imageTable", imageTable ) + , ( "imageTable0", imageTable0 ) + , ( "imageTable1", imageTable1 ) + , ( "imageTable2", imageTable2 ) + , ( "imageTable3", imageTable3 ) + , ( "toAbsHRefs", toAbsHRefs ) + , ( "toAbsRefs", toAbsRefs ) + , ( "toAbsRefs1", toAbsRefs1 ) ] processRootElement :: String -> IOSArrow XmlTree XmlTree diff --git a/examples/arrows/HelloWorld/HelloWorld.hs b/examples/arrows/HelloWorld/HelloWorld.hs --- a/examples/arrows/HelloWorld/HelloWorld.hs +++ b/examples/arrows/HelloWorld/HelloWorld.hs @@ -1,17 +1,17 @@ module Main where -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core import System.Exit main :: IO() main = do - [rc] <- runX ( readDocument [ (a_trace, "1") - , (a_validate, v_0) + [rc] <- runX ( readDocument [ withTrace 1 + , withValidate no ] "hello.xml" >>> - writeDocument [ (a_output_encoding, isoLatin1) + writeDocument [ withOutputEncoding utf8 ] "-" >>> getErrStatus diff --git a/examples/arrows/HelloWorld/Mini.hs b/examples/arrows/HelloWorld/Mini.hs --- a/examples/arrows/HelloWorld/Mini.hs +++ b/examples/arrows/HelloWorld/Mini.hs @@ -1,13 +1,15 @@ module Main where -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core main :: IO() main - = runX ( readDocument [ (a_validate, v_0) ] "hello.xml" + = runX ( configSysVars [ withTrace 1 ] >>> - writeDocument [ ] "bye.xml" + readDocument [ withValidate no ] "hello.xml" + >>> + writeDocument [ ] "bye.xml" ) >> return () diff --git a/examples/arrows/RegexXMLSchema/Makefile b/examples/arrows/RegexXMLSchema/Makefile deleted file mode 100644 --- a/examples/arrows/RegexXMLSchema/Makefile +++ /dev/null @@ -1,128 +0,0 @@ -# $Id: Makefile,v 1.9 2006/11/11 15:36:03 hxml Exp $ - -HXT_HOME = ../../.. -PKGFLAGS = -GHCFLAGS = -Wall -O2 -GHC = ghc $(GHCFLAGS) $(PKGFLAGS) - -DIST = $(HXT_HOME)/dist/examples/arrows -DIST_DIR = $(DIST)/RegexXMLSchema - -CNT = 3 - -ropts = +RTS -s -RTS - -prog = ./REtest -prog2 = ./Lines -prog3 = ./RElines -prog4 = ./Words -prog5 = ./REwords -prog0 = ./Copy - -progs = $(prog) $(prog0) $(prog2) $(prog3) $(prog4) $(prog5) - -all : $(progs) - -$(prog) : $(prog).hs - $(GHC) --make -o $@ $< - -local : - $(GHC) --make -o $(prog) -fglasgow-exts -ignore-package hxt -i../../../src $(prog).hs - -$(prog2) : $(prog) - ln -f $(prog) $(prog2) - -$(prog3) : $(prog) - ln -f $(prog) $(prog3) - -$(prog4) : $(prog) - ln -f $(prog) $(prog4) - -$(prog5) : $(prog) - ln -f $(prog) $(prog5) - -$(prog0) : $(prog) - ln -f $(prog) $(prog0) - -# generate and read documents containing a binary tree -# with 2^i leaf nodes containing the numbers 1 to 2^i -# for i up to at least 22 (8M XML elements) output works fine -# for i up to 19 (1M XML elements) input works without swapping -# with i=20 swapping starts, but the program it still terminates -# the size of the XML file for i=20 is about 36Mb -# these tests have run on a box with 1Gb memory - -tests = 18 - -test : $(prog) - $(MAKE) genfiles tests="$(tests)" - $(MAKE) copy tests="$(tests)" - $(MAKE) lines tests="$(tests)" - $(MAKE) relines tests="$(tests)" - $(MAKE) words tests="$(tests)" - $(MAKE) rewords tests="$(tests)" - -perftest : $(prog) - $(MAKE) test tests="2 3 10 11 12 13 14 15 16 17 18 19 20" - -genfiles : - @for i in $(tests) ; \ - do \ - echo time $(prog) $(ropts) $$i ; \ - time $(prog) $(ropts) $$i ; \ - ls -l tree-*$$i.xml ; \ - echo ; \ - done - -copy : - @for i in $(tests) ; \ - do \ - echo time $(prog0) $(ropts) $$i ; \ - time $(prog0) $(ropts) $$i ; \ - ls -l tree-*$$i.xml.copy ; \ - echo ; \ - done - -lines : - @for i in $(tests) ; \ - do \ - echo time $(prog2) $(ropts) $$i ; \ - time $(prog2) $(ropts) $$i ; \ - ls -l tree-*$$i.xml.lines ; \ - echo ; \ - done - -relines : - @for i in $(tests) ; \ - do \ - echo time $(prog3) $(ropts) $$i ; \ - time $(prog3) $(ropts) $$i ; \ - ls -l tree-*$$i.xml.relines ; \ - echo ; \ - done - -words : - @for i in $(tests) ; \ - do \ - echo time $(prog4) $(ropts) $$i ; \ - time $(prog4) $(ropts) $$i ; \ - ls -l tree-*$$i.xml.words ; \ - echo ; \ - done - -rewords : - @for i in $(tests) ; \ - do \ - echo time $(prog5) $$i ; \ - time $(prog5) $(ropts) $$i ; \ - ls -l tree-*$$i.xml.rewords ; \ - echo ; \ - done - -dist : - [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) - cp Makefile REtest.hs $(DIST_DIR) - -clean : - rm -f $(progs) *.o *.hi *.xml *.xml.* - diff --git a/examples/arrows/RegexXMLSchema/REtest.hs b/examples/arrows/RegexXMLSchema/REtest.hs deleted file mode 100644 --- a/examples/arrows/RegexXMLSchema/REtest.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE BangPatterns#-} - --- ---------------------------------------- - -module Main(main) -where - -import Text.XML.HXT.Arrow -import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch - -import Text.XML.HXT.DOM.Unicode - ( unicodeToXmlEntity - ) - -import Control.Monad.State.Strict hiding (when) - -import Data.Maybe - -import System.IO -- import the IO and commandline option stuff -import System.Environment - --- ---------------------------------------- - -main :: IO () -main - = do - p <- getProgName - al <- getArgs - let i = if null al - then 4 - else (read . head $ al)::Int - main' p i - where - main' p' = fromMaybe main1 . lookup (pn p') $ mpt - mpt = [ ("REtest", main1) - , ("Copy", main2 "copy" (:[])) - , ("Lines", main2 "lines" lines) - , ("RElines", main2 "relines" relines) - , ("Words", main2 "words" words) - , ("REwords", main2 "rewords" rewords) - ] - --- ---------------------------------------- - --- generate a document containing a binary tree of 2^i leafs (= 2^(i-1) XML elements) - -main1 :: Int -> IO () -main1 i - = runX (genDoc i (fn i)) - >> return () - --- ---------------------------------------- - --- read a document containing a binary tree of 2^i leafs - -main2 :: String -> (String -> [String]) -> Int -> IO () -main2 ext lines' i - = do - hPutStrLn stderr "start processing" - h <- openBinaryFile (fn i) ReadMode - c <- hGetContents h - let ls = lines' c - o <- openBinaryFile (fn i ++ "." ++ ext) WriteMode - mapM_ (hPutStrLn o) ls - hClose o - hClose h - hPutStrLn stderr "end processing" - -relines :: String -> [String] -relines = tokenize "[^\n\r]*" - -rewords :: String -> [String] -rewords = tokenize "[^ \t\n\r]+" - --- ---------------------------------------- - -pn :: String -> String -pn = reverse . takeWhile (/= '/') . reverse - -fn :: Int -> String -fn = ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show - --- ---------------------------------------- - -genDoc :: Int -> String -> IOSArrow b XmlTree -genDoc d out = constA (mkBTree d) - >>> - xpickleVal xpickle - >>> - indentDoc - >>> - putDoc out - --- ---------------------------------------- - -type Counter a = State Int a - -incr :: Counter Int -incr = do - modify (+1) - get - --- ---------------------------------------- - -data BTree = Leaf Int - | Fork BTree BTree - deriving (Show) - -instance XmlPickler BTree where - xpickle = xpAlt tag ps - where - tag (Leaf _ ) = 0 - tag (Fork _ _ ) = 1 - ps = [ xpWrap ( Leaf, \ (Leaf i) -> i) - ( xpElem "leaf" $ xpAttr "value" $ xpickle ) - - , xpWrap ( uncurry Fork, \ (Fork l r) -> (l, r)) - ( xpElem "fork" $ xpPair xpickle xpickle ) - ] - --- ---------------------------------------- - -mkBTree :: Int -> BTree -mkBTree depth = evalState (mkT depth) 0 - -mkT :: Int -> Counter BTree -mkT 0 = do - i <- incr - return (Leaf i) -mkT n = do - l <- mkT (n-1) - r <- mkT (n-1) - return (Fork l r) - --- ---------------------------------------- - --- output is done with low level ops to write the --- document i a lazy manner --- adding an xml pi and encoding is done "by hand" --- latin1 decoding is the identity, so please generate the --- docs with latin1 encoding. Here ist done even with ASCCI --- every none ASCII char is represented by a char ref (&nnn;) - -putDoc :: String -> IOStateArrow s XmlTree XmlTree -putDoc dst - = addXmlPi - >>> - addXmlPiEncoding isoLatin1 - >>> - xshow getChildren - >>> - arr unicodeToXmlEntity - >>> - arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s)) - >>> - none - where - isStdout = null dst || dst == "-" - - hPutDocument :: (Handle -> IO()) -> IO() - hPutDocument action - | isStdout - = action stdout - | otherwise - = do - handle <- openBinaryFile dst WriteMode - action handle - hClose handle - --- ---------------------------------------- diff --git a/examples/arrows/absurls/AbsURIs.hs b/examples/arrows/absurls/AbsURIs.hs --- a/examples/arrows/absurls/AbsURIs.hs +++ b/examples/arrows/absurls/AbsURIs.hs @@ -9,9 +9,8 @@ Maintainer : uwe@fh-wedel.de Stability : experimental Portability: portable - Version : $Id: AbsURIs.hs,v 1.1 2005/05/12 16:41:38 hxml Exp $ -AbsURIs - Conversion references into absolute URIs in HTML pages + AbsURIs - Conversion references into absolute URIs in HTML pages The commandline interface -} @@ -21,9 +20,9 @@ module Main where -import Text.XML.HXT.Arrow -- import all stuff for parsing, validating, and transforming XML +import Text.XML.HXT.Core -- import all stuff for parsing, validating, and transforming XML -import System.IO -- import the IO and commandline option stuff +import System.IO -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit @@ -38,16 +37,16 @@ main :: IO () main = do - argv <- getArgs -- get the commandline arguments - (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list - [rc] <- runX (parser al src) -- run the parser arrow - exitProg (rc >= c_err) -- set return code and terminate + argv <- getArgs -- get the commandline arguments + (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list + [rc] <- runX (parser al src) -- run the parser arrow + exitProg (rc >= c_err) -- set return code and terminate -- ------------------------------------------------------------ -exitProg :: Bool -> IO a -exitProg True = exitWith (ExitFailure (-1)) -exitProg False = exitWith ExitSuccess +exitProg :: Bool -> IO a +exitProg True = exitWith (ExitFailure (-1)) +exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------ @@ -57,10 +56,12 @@ -- get wellformed document, validates document, propagates and check namespaces -- and controls output -parser :: Attributes -> String -> IOSArrow b Int -parser al src - = readDocument ([(a_parse_html, v_1)] ++ al) src +parser :: SysConfigList -> String -> IOSArrow b Int +parser config src + = configSysVars config -- set all global config options >>> + readDocument [withParseHTML yes] src -- use HTML parser + >>> traceMsg 1 "start processing" >>> processDocument @@ -71,7 +72,7 @@ >>> traceTree >>> - writeDocument al "-" `whenNot` hasAttr "no-output" + ( writeDocument [] $< getSysAttr "output-file" ) >>> getErrStatus @@ -80,51 +81,55 @@ -- the options definition part -- see doc for System.Console.GetOpt -progName :: String -progName = "AbsURIs" +progName :: String +progName = "AbsURIs" -options :: [OptDescr (String, String)] +options :: [OptDescr SysConfig] options = generalOptions ++ - selectOptions [a_trace, a_proxy, a_use_curl, a_issue_warnings, a_do_not_issue_warnings, a_do_not_use_curl, a_options_curl, a_encoding] inputOptions + inputOptions ++ + [ Option "f" ["output-file"] (ReqArg (withSysAttr "output-file") "FILE") + "output file for resulting document (default: stdout)" + ] + ++ outputOptions ++ showOptions -usage :: [String] -> IO a +usage :: [String] -> IO a usage errl | null errl - = do - hPutStrLn stdout use - exitProg False + = do + hPutStrLn stdout use + exitProg False | otherwise - = do - hPutStrLn stderr (concat errl ++ "\n" ++ use) - exitProg True + = do + hPutStrLn stderr (concat errl ++ "\n" ++ use) + exitProg True where header = progName ++ " - Convert all references in an HTML document into absolute URIs\n\n" ++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]" use = usageInfo header options -cmdlineOpts :: [String] -> IO (Attributes, String) +cmdlineOpts :: [String] -> IO (SysConfigList, String) cmdlineOpts argv = case (getOpt Permute options argv) of - (ol,n,[]) - -> do - sa <- src n - help (lookup a_help ol) sa - return (ol, sa) + (scfg,n,[]) + -> do + sa <- src n + help (getConfigAttr a_help scfg) sa + return (scfg, sa) (_,_,errs) - -> usage errs + -> usage errs where - src [] = return [] - src [uri] = return uri - src _ = usage ["only one input uri or file allowed\n"] + src [] = return [] + src [uri] = return uri + src _ = usage ["only one input uri or file allowed\n"] - help (Just _) _ = usage [] - help Nothing [] = usage ["no input uri or file given\n"] - help Nothing _ = return () + help "1" _ = usage [] + help _ [] = usage ["no input uri or file given\n"] + help _ _ = return () -- ------------------------------------------------------------ diff --git a/examples/arrows/absurls/ProcessDocument.hs b/examples/arrows/absurls/ProcessDocument.hs --- a/examples/arrows/absurls/ProcessDocument.hs +++ b/examples/arrows/absurls/ProcessDocument.hs @@ -9,11 +9,10 @@ Maintainer : uwe@fh-wedel.de Stability : experimental Portability: portable - Version : $Id: ProcessDocument.hs,v 1.2 2005/05/15 17:01:04 hxml Exp $ -AbsURIs - Conversion references into absolute URIs in HTML pages + AbsURIs - Conversion references into absolute URIs in HTML pages -The REAL processing functions + The REAL processing functions -} -- ------------------------------------------------------------ @@ -22,7 +21,7 @@ ( processDocument ) where -import Text.XML.HXT.Arrow -- import all stuff for parsing, validating, and transforming XML +import Text.XML.HXT.Core -- import all stuff for parsing, validating, and transforming XML import Data.Maybe diff --git a/examples/arrows/dtd2hxt/DTDtoHXT.hs b/examples/arrows/dtd2hxt/DTDtoHXT.hs --- a/examples/arrows/dtd2hxt/DTDtoHXT.hs +++ b/examples/arrows/dtd2hxt/DTDtoHXT.hs @@ -4,22 +4,20 @@ -- -- Author : Uwe Schmidt -- --- Version : $Id: DTDtoHXT.hs,v 1.3 2005/04/14 12:52:50 hxml Exp $ --- -- this program may be used as example main program for the -- Haskell XML Toolbox module Main where -import Text.XML.HXT.Arrow -- import all stuff for parsing, validating, and transforming XML +import Text.XML.HXT.Core -- import all stuff for parsing, validating, and transforming XML +import Text.XML.HXT.Curl -import System.IO -- import the IO and commandline option stuff +import System.IO -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit -import Data.Maybe import Data.Char import Data.List @@ -31,43 +29,43 @@ main :: IO () main = do - argv <- getArgs -- get the commandline arguments - (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list + argv <- getArgs -- get the commandline arguments + (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list [rc] <- runX (dtd2hxt al src) exitProg (rc >= c_err) -- ------------------------------------------------------------ -exitProg :: Bool -> IO a -exitProg True = exitWith (ExitFailure (-1)) -exitProg False = exitWith ExitSuccess +exitProg :: Bool -> IO a +exitProg True = exitWith (ExitFailure (-1)) +exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------ -- -- options -uppercaseInitials, namespaceAware, prefixUnderline :: String +uppercaseInitials, namespaceAware, prefixUnderline :: String -uppercaseInitials = "uppercase-initials" -namespaceAware = "namespace-aware" -prefixUnderline = "prefix-underline" +uppercaseInitials = "uppercase-initials" +namespaceAware = "namespace-aware" +prefixUnderline = "prefix-underline" -- name prefixes tagPrefix, attPrefix, nsPrefix, isPrefix, mkPrefix, hasPrefix, getPrefix , mkAttPrefix, mkSAttPrefix - , nsDefault :: String + , nsDefault :: String -tagPrefix = "tag" -attPrefix = "attr" -nsPrefix = "ns" -isPrefix = "is" -mkPrefix = "e" -hasPrefix = "has" -getPrefix = "get" -mkAttPrefix = "a" -mkSAttPrefix = "sa" -nsDefault = "default" +tagPrefix = "tag" +attPrefix = "attr" +nsPrefix = "ns" +isPrefix = "is" +mkPrefix = "e" +hasPrefix = "has" +getPrefix = "get" +mkAttPrefix = "a" +mkSAttPrefix = "sa" +nsDefault = "default" -- ------------------------------------------------------------ @@ -78,10 +76,14 @@ -- (this would remove the DTD), -- and controls output -dtd2hxt :: Attributes -> String -> IOSArrow b Int -dtd2hxt al src - = readDocument ((a_canonicalize, v_0) : al) src +dtd2hxt :: SysConfigList -> String -> IOSArrow b Int +dtd2hxt config src + = configSysVars config -- set all global config options >>> + readDocument [withCanonicalize no + ,withCurl [] + ] src + >>> traceMsg 1 "start processing DTD" >>> processChildren (isDTD `guards` genHXT) @@ -92,195 +94,195 @@ >>> traceTree >>> - writeDocument ((a_output_xml, v_0) : al) (fromMaybe "" (lookup a_output_file al)) + ( writeDocument [withOutputPLAIN] $< getSysAttr "output-file" ) >>> getErrStatus where genHXT - = catA $ map (>>> mkText) $ - [ getModuleName -- the module header - >>> - arr genModHead + = catA $ map (>>> mkText) $ + [ getModuleName -- the module header + >>> + arr genModHead - , constA $ comm "namespace declarations" + , constA $ comm "namespace declarations" - , getNSAttr -- namespace constants - >>> -- declared as "xmlns" or "xmlns:" attribute with #FIXED values - arr2 genNSCode + , getNSAttr -- namespace constants + >>> -- declared as "xmlns" or "xmlns:" attribute with #FIXED values + arr2 genNSCode - , constA $ comm "element arrows" + , constA $ comm "element arrows" - , getElems >>. sort -- element processing - >>> - arr genElemCode + , getElems >>. sort -- element processing + >>> + arr genElemCode - , getAttrs >>. ( sort . nub ) -- attribute processing + , getAttrs >>. ( sort . nub ) -- attribute processing >>> - arr genAttrCode + arr genAttrCode - , getModuleName -- module footer + , getModuleName -- module footer >>> arr genModFoot - ] + ] -- auxiliary arrows -------------------------------------------------- - getModuleName :: (ArrowXml a, ArrowDTD a) => a XmlTree String + getModuleName :: (ArrowXml a, ArrowDTD a) => a XmlTree String getModuleName - = isDTDDoctype - >>> - getDTDAttrValue a_name - >>> - arr moduleName + = isDTDDoctype + >>> + getDTDAttrValue a_name + >>> + arr moduleName -- filter namespace attributes ---------------------------------------- - getNSAttr :: (ArrowXml a, ArrowDTD a) => a XmlTree (String, String) + getNSAttr :: (ArrowXml a, ArrowDTD a) => a XmlTree (String, String) getNSAttr - = deep isDTDAttlist - >>> - ( ( getDTDAttrValue a_value >>> isA (\ s -> s == "xmlns" || "xmlns:" `isPrefixOf` s) - ) - `guards` - ( ( getDTDAttrValue a_kind >>> isA (== k_fixed) - ) - `guards` - ( ( getDTDAttrValue a_value >>> arr (drop 6) ) -- remove "xmlns:" prefix - &&& - getDTDAttrValue a_default - ) - ) - ) + = deep isDTDAttlist + >>> + ( ( getDTDAttrValue a_value >>> isA (\ s -> s == "xmlns" || "xmlns:" `isPrefixOf` s) + ) + `guards` + ( ( getDTDAttrValue a_kind >>> isA (== k_fixed) + ) + `guards` + ( ( getDTDAttrValue a_value >>> arr (drop 6) ) -- remove "xmlns:" prefix + &&& + getDTDAttrValue a_default + ) + ) + ) - getElems :: (ArrowXml a, ArrowDTD a) => a XmlTree String + getElems :: (ArrowXml a, ArrowDTD a) => a XmlTree String getElems - = deep isDTDElement - >>> - getDTDAttrValue a_name + = deep isDTDElement + >>> + getDTDAttrValue a_name - getAttrs :: (ArrowXml a, ArrowDTD a) => a XmlTree String + getAttrs :: (ArrowXml a, ArrowDTD a) => a XmlTree String getAttrs - = deep isDTDAttlist - >>> - getDTDAttrValue a_value + = deep isDTDAttlist + >>> + getDTDAttrValue a_value -- code generation ------------------------------------------------------------ - genModHead :: String -> String + genModHead :: String -> String genModHead rootElem - = code [ sepl - , "--" - , "-- don't edit this module" - , "-- generated with " ++ progName - , "-- simple access function for Haskell XML Toolbox" - , "-- generated from DTD of document: " ++ show src - , "" - , "module " ++ rootElem ++ " ( module " ++ rootElem ++ " )" - , "where" - , "" - , "import Text.XML.HXT.Arrow (XmlTree, ArrowXml, (>>>))" - , "import qualified Text.XML.HXT.Arrow as X (attr, eelem, getAttrValue, hasAttr, hasName, isElem, sattr)" - ] + = code [ sepl + , "--" + , "-- don't edit this module" + , "-- generated with " ++ progName + , "-- simple access function for Haskell XML Toolbox" + , "-- generated from DTD of document: " ++ show src + , "" + , "module " ++ rootElem ++ " ( module " ++ rootElem ++ " )" + , "where" + , "" + , "import Text.XML.HXT.Core (XmlTree, ArrowXml, (>>>))" + , "import qualified Text.XML.HXT.Core as X (attr, eelem, getAttrValue, hasAttr, hasName, isElem, sattr)" + ] - genNSCode :: String -> String -> String + genNSCode :: String -> String -> String genNSCode prefix ns - = code [ ns' ++ "\t:: String" - , ns' ++ "\t= " ++ show ns - ] - where - ns' = nsPrefix ++ nn (if null prefix then nsDefault else prefix) + = code [ ns' ++ "\t:: String" + , ns' ++ "\t= " ++ show ns + ] + where + ns' = nsPrefix ++ nn (if null prefix then nsDefault else prefix) - genElemCode :: String -> String - genElemCode n - = code [ comm ("arrows for element " ++ show n) - , tagN ++ "\t:: String" - , tagN ++ "\t= " ++ show n - , "" - , isN ++ "\t:: ArrowXml a => a XmlTree XmlTree" - , isN ++ "\t= X.isElem >>> X.hasName " ++ tagN - , "" - , mkN ++ "\t:: ArrowXml a => a n XmlTree" - , mkN ++ "\t= X.eelem " ++ tagN - ] - where - tagN = tagPrefix ++ nn n - isN = isPrefix ++ nn n - mkN = mkPrefix ++ nn n + genElemCode :: String -> String + genElemCode n + = code [ comm ("arrows for element " ++ show n) + , tagN ++ "\t:: String" + , tagN ++ "\t= " ++ show n + , "" + , isN ++ "\t:: ArrowXml a => a XmlTree XmlTree" + , isN ++ "\t= X.isElem >>> X.hasName " ++ tagN + , "" + , mkN ++ "\t:: ArrowXml a => a n XmlTree" + , mkN ++ "\t= X.eelem " ++ tagN + ] + where + tagN = tagPrefix ++ nn n + isN = isPrefix ++ nn n + mkN = mkPrefix ++ nn n - genAttrCode :: String -> String - genAttrCode n - = code [ comm ("arrows for attribute " ++ show n) - , attN ++ "\t:: String" - , attN ++ "\t= " ++ show n - , "" - , hasN ++ "\t:: ArrowXml a => a XmlTree XmlTree" - , hasN ++ "\t= X.hasAttr " ++ attN - , "" - , getN ++ "\t:: ArrowXml a => a XmlTree String" - , getN ++ "\t= X.getAttrValue " ++ attN - , "" - , mkN ++ "\t:: ArrowXml a => a n XmlTree -> a n XmlTree" - , mkN ++ "\t= X.attr " ++ attN - , "" - , mksN ++ "\t:: ArrowXml a => String -> a n XmlTree" - , mksN ++ "\t= X.sattr " ++ attN - ] - where - attN = attPrefix ++ nn n - hasN = hasPrefix ++ nn n - getN = getPrefix ++ nn n ++ nn "value" - mkN = mkAttPrefix ++ nn n - mksN = mkSAttPrefix ++ nn n + genAttrCode :: String -> String + genAttrCode n + = code [ comm ("arrows for attribute " ++ show n) + , attN ++ "\t:: String" + , attN ++ "\t= " ++ show n + , "" + , hasN ++ "\t:: ArrowXml a => a XmlTree XmlTree" + , hasN ++ "\t= X.hasAttr " ++ attN + , "" + , getN ++ "\t:: ArrowXml a => a XmlTree String" + , getN ++ "\t= X.getAttrValue " ++ attN + , "" + , mkN ++ "\t:: ArrowXml a => a n XmlTree -> a n XmlTree" + , mkN ++ "\t= X.attr " ++ attN + , "" + , mksN ++ "\t:: ArrowXml a => String -> a n XmlTree" + , mksN ++ "\t= X.sattr " ++ attN + ] + where + attN = attPrefix ++ nn n + hasN = hasPrefix ++ nn n + getN = getPrefix ++ nn n ++ nn "value" + mkN = mkAttPrefix ++ nn n + mksN = mkSAttPrefix ++ nn n - genModFoot :: String -> String + genModFoot :: String -> String genModFoot rootElem - = comm ( "end of module " ++ rootElem) + = comm ( "end of module " ++ rootElem) -- string manipulation -------------------------------------------------- - code :: [String] -> String - code = concatMap (++ "\n") + code :: [String] -> String + code = concatMap (++ "\n") - comm :: String -> String - comm cm = code [ "", sepl, "--", "-- " ++ cm, ""] + comm :: String -> String + comm cm = code [ "", sepl, "--", "-- " ++ cm, ""] - sepl :: String - sepl = "-- ----------------------------------------" + sepl :: String + sepl = "-- ----------------------------------------" - moduleName :: String -> String + moduleName :: String -> String moduleName rootElem - = modname . fromMaybe rootElem . lookup a_output_file $ al + = modname . (\ x -> if null x then rootElem else x) . getConfigAttr "output_file" $ config modname - = (\ x -> toUpper (head x) : tail x) - . reverse - . (\ n -> if '.' `elem` n -- remove extension - then drop 1 . dropWhile (/= '.') $ n - else n - ) - . takeWhile (/= '/') -- remove dir path - . reverse + = (\ x -> toUpper (head x) : tail x) + . reverse + . (\ n -> if '.' `elem` n -- remove extension + then drop 1 . dropWhile (/= '.') $ n + else n + ) + . takeWhile (/= '/') -- remove dir path + . reverse - nn :: String -> String + nn :: String -> String nn - = trInitial . concatMap nc -- normalize names + = trInitial . concatMap nc -- normalize names - nc :: Char -> String + nc :: Char -> String nc c - | c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" = [c] - | c == ':' || c == '-' = "_" - | otherwise = ("_" ++) . show . fromEnum $ c + | c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" = [c] + | c == ':' || c == '-' = "_" + | otherwise = ("_" ++) . show . fromEnum $ c - trInitial :: String -> String + trInitial :: String -> String trInitial str - | null str = str - | underLn = '_' : str - | upperCs = toUpper (head str) : tail str - | otherwise = str + | null str = str + | underLn = '_' : str + | upperCs = toUpper (head str) : tail str + | otherwise = str - upperCs, underLn {-, nsAware -} :: Bool - upperCs = isJust . lookup uppercaseInitials $ al - underLn = isJust . lookup prefixUnderline $ al - {- nsAware = isJust . lookup namespaceAware $ al -} + upperCs, underLn {-, nsAware -} :: Bool + upperCs = (== "1") . getConfigAttr uppercaseInitials $ config + underLn = (== "1") . getConfigAttr prefixUnderline $ config + _nsAware = (== "1") . getConfigAttr namespaceAware $ config -- ------------------------------------------------------------ -- @@ -288,64 +290,62 @@ -- -- see doc for System.Console.GetOpt -progName :: String -progName = "DTDtoHXT" +progName :: String +progName = "DTDtoHXT" -options :: [OptDescr (String, String)] +options :: [OptDescr SysConfig] options = selectOptions [ a_help - ] generalOptions + ] generalOptions ++ selectOptions [ a_trace - , a_proxy - , a_use_curl - , a_options_curl - , a_encoding - , a_validate - , a_check_namespaces - ] inputOptions + , a_proxy + , a_encoding + , a_validate + , a_check_namespaces + ] inputOptions ++ - selectOptions [ a_output_file - ] outputOptions + selectOptions [ "output-file" + ] outputOptions ++ - [ Option "u" [prefixUnderline] (NoArg (prefixUnderline, v_1)) "separate tag and attribute names with a '_'" - , Option "U" [uppercaseInitials] (NoArg (uppercaseInitials, v_1)) "transform the first char of tag and attribute names to uppercase" - -- , Option "N" [namespaceAware] (NoArg (namespaceAware, v_1)) "filter are namespace aware, if namespace attributes occur in the DTD" + [ Option "u" [prefixUnderline] (NoArg $ withSysAttr prefixUnderline "1") "separate tag and attribute names with a '_'" + , Option "U" [uppercaseInitials] (NoArg $ withSysAttr uppercaseInitials "1") "transform the first char of tag and attribute names to uppercase" + , Option "N" [namespaceAware] (NoArg $ withSysAttr namespaceAware "1") "filter are namespace aware, if namespace attributes occur in the DTD" ] ++ showOptions -usage :: [String] -> IO a +usage :: [String] -> IO a usage errl | null errl - = do - hPutStrLn stdout use - exitProg False + = do + hPutStrLn stdout use + exitProg False | otherwise - = do - hPutStrLn stderr (concat errl ++ "\n" ++ use) - exitProg True + = do + hPutStrLn stderr (concat errl ++ "\n" ++ use) + exitProg True where header = "DTDtoHXml - Generation of access function for the Haskell XML Toolbox from a DTD\n" ++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]" use = usageInfo header options -cmdlineOpts :: [String] -> IO (Attributes, String) +cmdlineOpts :: [String] -> IO (SysConfigList, String) cmdlineOpts argv = case (getOpt Permute options argv) of (ol,n,[] ) - -> do - sa <- src n - help (lookup a_help ol) - return (ol, sa) + -> do + sa <- src n + help (getConfigAttr a_help ol) + return (ol, sa) (_,_,errs) - -> usage errs + -> usage errs where - src [uri] = return uri - src [] = usage ["input file/uri missing"] - src _ = usage ["only one input url or file allowed\n"] + src [uri] = return uri + src [] = usage ["input file/uri missing"] + src _ = usage ["only one input url or file allowed\n"] - help Nothing = return () - help (Just _) = usage [] + help "1" = usage [] + help _ = return () -- ------------------------------------------------------------ diff --git a/examples/arrows/hparser/HXmlParser.hs b/examples/arrows/hparser/HXmlParser.hs --- a/examples/arrows/hparser/HXmlParser.hs +++ b/examples/arrows/hparser/HXmlParser.hs @@ -10,7 +10,7 @@ Stability : experimental Portability: portable - HXmlParser - Validating XML Parser of the Haskell XML Toolbox + HXmlParser - Minimal Validating XML Parser of the Haskell XML Toolbox, no HTTP supported XML well-formed checker and validator. @@ -28,15 +28,13 @@ module Main where -import Text.XML.HXT.Arrow -- import all stuff for parsing, validating, and transforming XML +import Text.XML.HXT.Core -- import all stuff for parsing, validating, and transforming XML -import System.IO -- import the IO and commandline option stuff +import System.IO -- import the IO and commandline option stuff import System.Environment import System.Console.GetOpt import System.Exit -import Data.Maybe - -- ------------------------------------------------------------ -- | @@ -45,16 +43,16 @@ main :: IO () main = do - argv <- getArgs -- get the commandline arguments - (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list - [rc] <- runX (parser al src) -- run the parser arrow - exitProg (rc >= c_err) -- set return code and terminate + argv <- getArgs -- get the commandline arguments + (al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list + [rc] <- runX (parser al src) -- run the parser arrow + exitProg (rc >= c_err) -- set return code and terminate -- ------------------------------------------------------------ -exitProg :: Bool -> IO a -exitProg True = exitWith (ExitFailure (-1)) -exitProg False = exitWith ExitSuccess +exitProg :: Bool -> IO a +exitProg True = exitWith (ExitFailure (-1)) +exitProg False = exitWith ExitSuccess -- ------------------------------------------------------------ @@ -64,98 +62,109 @@ -- get wellformed document, validates document, propagates and check namespaces -- and controls output -parser :: Attributes -> String -> IOSArrow b Int -parser al src - = readDocument al src +parser :: SysConfigList -> String -> IOSArrow b Int +parser config src + = configSysVars config -- set all global config options, the output file and the + >>> -- other user options are stored as key-value pairs in the stystem state + readDocument [] src -- no more special read options needed >>> ( ( traceMsg 1 "start processing document" - >>> - processDocument al - >>> - traceMsg 1 "document processing finished" - ) - `when` - documentStatusOk + >>> + ( processDocument $< getSysAttr "action" ) -- ask for the action stored in the key-value list of user defined values + >>> + traceMsg 1 "document processing finished" + ) + `when` + documentStatusOk ) >>> traceSource >>> traceTree >>> - writeDocument al (fromMaybe "-" . lookup a_output_file $ al) `whenNot` hasAttr "no-output" + ( (writeDocument [] $< getSysAttr "output-file") -- ask for the output file stored in the system configuration + `whenNot` + ( getSysAttr "no-output" >>> isA (== "1") ) -- ask for the no-output attr value in the system key-value list + ) >>> getErrStatus --- simple example of a processing arrow +-- simple example of a processing arrow, selected by a command line option -processDocument :: Attributes -> IOSArrow XmlTree XmlTree -processDocument al - | extractText - = traceMsg 1 "selecting plain text" - >>> - processChildren (deep isText) - | otherwise - = this - where - extractText = optionIsSet "show-text" $ al +processDocument :: String -> IOSArrow XmlTree XmlTree +processDocument "only-text" + = traceMsg 1 "selecting plain text" + >>> + processChildren (deep isText) +processDocument "indent" + = traceMsg 1 "indent document" + >>> + indentDoc + +processDocument _action + = traceMsg 1 "default action: do nothing" + >>> + this + -- ------------------------------------------------------------ -- -- the options definition part -- see doc for System.Console.GetOpt -progName :: String -progName = "HXmlParser" +progName :: String +progName = "HXmlParser" -options :: [OptDescr (String, String)] +options :: [OptDescr SysConfig] options = generalOptions ++ inputOptions ++ - relaxOptions - ++ outputOptions ++ - [ Option "q" ["no-output"] (NoArg ("no-output", "1")) "no output of resulting document" - , Option "x" ["show-text"] (NoArg ("show-text", "1")) "output only the raw text, remove all markup" - ] - ++ showOptions + ++ + [ Option "f" ["output-file"] (ReqArg (withSysAttr "output-file") "FILE") "output file for resulting document (default: stdout)" + , Option "q" ["no-output"] (NoArg $ withSysAttr "no-output" "1") "no output of resulting document" + , Option "x" ["action"] (ReqArg (withSysAttr "action") "ACTION") "actions are: only-text, indent, no-op" + ] + -- the last 2 option values will be stored by withAttr in the system key-value list + -- and can be read by getSysAttr key -usage :: [String] -> IO a +usage :: [String] -> IO a usage errl | null errl - = do - hPutStrLn stdout use - exitProg False + = do + hPutStrLn stdout use + exitProg False | otherwise - = do - hPutStrLn stderr (concat errl ++ "\n" ++ use) - exitProg True + = do + hPutStrLn stderr (concat errl ++ "\n" ++ use) + exitProg True where header = "HXmlParser - Validating XML Parser of the Haskell XML Toolbox with Arrow Interface\n" ++ - "XML well-formed checker, DTD validator, Relax NG validator.\n\n" ++ + "XML well-formed checker, DTD validator, HTML parser.\n\n" ++ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]" use = usageInfo header options -cmdlineOpts :: [String] -> IO (Attributes, String) +cmdlineOpts :: [String] -> IO (SysConfigList, String) cmdlineOpts argv = case (getOpt Permute options argv) of - (ol,n,[]) - -> do - sa <- src n - help (lookup a_help ol) sa - return (ol, sa) + (scfg,n,[]) + -> do + sa <- src n + help (getConfigAttr a_help scfg) sa + return (scfg, sa) (_,_,errs) - -> usage errs + -> usage errs where - src [] = return [] - src [uri] = return uri - src _ = usage ["only one input uri or file allowed\n"] + src [] = return [] + src [uri] = return uri + src _ = usage ["only one input uri or file allowed\n"] - help (Just _) _ = usage [] - help Nothing [] = usage ["no input uri or file given\n"] - help Nothing _ = return () + help "1" _ = usage [] + help _ [] = usage ["no input uri or file given\n"] + help _ _ = return () -- ------------------------------------------------------------ diff --git a/examples/arrows/hparser/Makefile b/examples/arrows/hparser/Makefile --- a/examples/arrows/hparser/Makefile +++ b/examples/arrows/hparser/Makefile @@ -29,7 +29,7 @@ @echo "===> first see all command line options" $(prog) --help @echo - $(MAKE) test0 test1 test2 test3 test4 test5 + $(MAKE) test0 test1 test2 test3 test4 EX1 = ./example1.xml EXi = ./invalid.xml @@ -74,7 +74,7 @@ $(prog) --show-tree --output-encoding=ISO-8859-1 $(EX1) @echo @sleep 2 ; echo ; echo "===> once again, but without any markup" ; echo ; sleep 2 - $(prog) --show-text --output-encoding=ISO-8859-1 $(EX1) + $(prog) --action=only-text --output-encoding=ISO-8859-1 $(EX1) @echo test2 : @@ -84,14 +84,14 @@ @sleep 2 ; echo ; echo "===> parser will validate this document and try to indent the output" ; echo ; sleep 2 $(prog) --indent $(EX2) @sleep 2 ; echo ; echo "===> once again, but remove all markup" ; echo ; sleep 2 - $(prog) --show-text --remove-whitespace $(EX2) + $(prog) --action=only-text --remove-whitespace $(EX2) @sleep 2 ; echo ; echo "===> once again with hdom tree output" ; echo ; sleep 2 $(prog) --show-tree --remove-whitespace $(EX2) test3 : @echo "===> namespace processing examples" ; echo ; sleep 2 @echo "===> namespace propagation test" ; echo ; sleep 2 - $(prog) --verbose --check-namespaces --indent --output-encoding=ISO-8859-1 $(EX3) + $(prog) --verbose --check-namespaces --indent --output-encoding=UTF-8 $(EX3) @echo @echo ; sleep 2 ; echo "===> namespace propagation test: tree output with attached namespaces" ; echo ; sleep 2 $(prog) --verbose --check-namespaces --remove-whitespace --show-tree --output-encoding=ISO-8859-1 $(EX3) @@ -107,51 +107,12 @@ cat $(EX4) @sleep 2 ; echo ; echo "===> parser accepts this document and tries to build a document tree" ; echo ; sleep 2 $(prog) --indent --preserve-comment --parse-html $(EX4) - @sleep 2 ; echo ; echo "===> same with lazy parser with tagsoup" ; echo ; sleep 2 - $(prog) -H -T -r --indent $(EX4) - @echo @echo "===> the source of another lousy html document containing empty elements" ; echo ; sleep 2 cat $(EX4a) @sleep 2 ; echo ; echo "===> parser accepts this document and tries to format this as a HTML document without any dangarous empty elements" ; echo ; sleep 2 $(prog) --indent --preserve-comment --parse-html --output-html --no-empty-elements $(EX4a) @echo - -test5 : - @echo "===> Validate a valid xml file with respect to a valid Relax NG schema" ; echo ; sleep 1 - @echo "the XML document ./valid1.xml" - @cat ./valid1.xml - @echo "the Relax NG schema ./valid1.rng" - @cat ./valid1.rng - @echo - $(prog) --relax-schema ./valid1.rng ./valid1.xml - @echo - @echo "===> Validate an invalid xml file with respect to a valid Relax NG schema" ; echo ; sleep 1 - @echo "the invalid XML document ./invalid1.xml" - @cat ./valid1.xml - $(prog) --relax-schema ./valid1.rng ./invalid1.xml || true - @echo - @echo "===> Incorrect Relax NG schema" ; echo ; sleep 1 - $(prog) --relax-schema ./invalid2.rng ./valid1.xml || true - @echo - @echo "===> Incorrect Relax NG schema with two errors" ; echo ; sleep 1 - $(prog) --relax-schema ./invalid3.rng ./valid1.xml || true - @echo - -test6 : - @echo "===> tagsoup parsing examples" ; echo ; sleep 2 - @echo "===> lousy HTML document" ; echo ; sleep 2 - $(prog) --tagsoup --parse-html lousy.html - @echo "===> www.w3c.org homepage (valid XHTML)" ; echo ; sleep 2 - $(prog) --tagsoup http://www.w3c.org/ - @echo "===> same again with removed whitespace and tree output" ; echo ; sleep 2 - $(prog) --tagsoup --remove-whitespace --show-tree http://www.w3c.org/ - @echo "===> same procedure with www.haskell.org homepage (rather valid HTML)" ; echo ; sleep 2 - $(prog) --tagsoup --parse-html http://www.haskell.org/ - @echo "===> same again with removed whitespace and tree output" ; echo ; sleep 2 - $(prog) --tagsoup --parse-html --remove-whitespace --show-tree http://www.haskell.org/ - @echo - dist : [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) cp $(EX) Makefile $(prog).hs $(DIST_DIR) @@ -159,4 +120,4 @@ clean : rm -f $(prog) *.o *.hi -.PHONY : all test test0 test1 test2 test3 test4 test5 test6 dist clean prof local force +.PHONY : all test test0 test1 test2 test3 test4 dist clean prof local force diff --git a/examples/arrows/hrelaxng/.ghci b/examples/arrows/hrelaxng/.ghci deleted file mode 100644 --- a/examples/arrows/hrelaxng/.ghci +++ /dev/null @@ -1,3 +0,0 @@ -:set -i../../../src -:set -Wall -fglasgow-exts -:load HRelaxNG diff --git a/examples/arrows/hrelaxng/HRelaxNG.hs b/examples/arrows/hrelaxng/HRelaxNG.hs deleted file mode 100644 --- a/examples/arrows/hrelaxng/HRelaxNG.hs +++ /dev/null @@ -1,170 +0,0 @@ --- | --- HRelaxNG - Relax NG Validator of the Haskell XML Toolbox. --- RELAX NG is a simpler schema language for XML. --- --- Author : Torben Kuseler --- --- Version : $Id: HRelaxNG.hs,v 1.2 2005/09/30 14:41:44 hxml Exp $ --- --- This program may be used as example main program for the --- Relax NG Validator. --- - -module Main -where - -import System.IO -import System.Environment -import System.Console.GetOpt -import System.Exit - -import Text.XML.HXT.Arrow -import Text.XML.HXT.RelaxNG - --- ------------------------------------------------------------ - - -main :: IO () -main - = do - argv <- getArgs -- get the commandline arguments - (al, xml, schema) <- cmdlineOpts argv -- and evaluate them, return a key-value list - [rc] <- runX (relax al xml schema) -- run the Relax NG validator - exitProg (rc >= c_err) -- set return code and terminate - -{- -relax :: Attributes -> String -> String -> IOSArrow b Int -relax al xml schema - = readDocument al schema - >>> - createSimpleForm - >>> - ( getErrors -- compute errors in schema - `orElse` - validateXMLDoc [] xml -- compute errors in document - `orElse` - root [] [txt "valid"] -- or document is valid - ) - >>> - writeDocument [(a_show_tree, "1")] "-" - >>> - getErrStatus --} - -relax :: Attributes -> String -> String -> IOSArrow b Int -relax al xml schema - = readDocument ( [ (a_check_namespaces, v_1) - , (a_validate, v_0) - ] ++ al - ) xml - >>> - traceState - >>> - validateDocumentWithRelaxSchema al schema - >>> - traceState - >>> - writeDocument al "-" - >>> - getErrStatus - - -exitProg :: Bool -> IO a -exitProg True = exitWith (ExitFailure (-1)) -exitProg False = exitWith ExitSuccess - - - --- ------------------------------------------------------------ --- --- the options definition part --- see doc for System.Console.GetOpt - -progName :: String -progName = "HRelaxNGValidator" - -options :: [OptDescr (String, String)] -options - = generalOptions - ++ - inputOptions - ++ - outputOptions - ++ - relaxOptions - -usage :: [String] -> IO a -usage errl - | null errl - = do - hPutStrLn stdout use - exitProg False - | otherwise - = do - hPutStrLn stderr (concat errl ++ "\n" ++ use) - exitProg True - where - header = "HRelaxNGValidator - Relax NG schema validator of the " ++ - "Haskell XML Toolbox with Arrow Interface\n\n" ++ - "Usage: " ++ progName ++ " [OPTION...] (XML file URI/FILE) (Relax NG Schema URI/FILE)" - use = usageInfo header options - -cmdlineOpts :: [String] -> IO (Attributes, String, String) -cmdlineOpts argv - = case (getOpt Permute options argv) of - (ol,n,[]) - -> do - (xml, schema) <- src n - help (lookup a_help ol) - return (ol, xml, schema) - (_,_,errs) - -> usage errs - where - src [xml, schema] = return (xml, schema) - src [] = usage ["XML file and Relax NG schema input file/url missing"] - src [_] = usage ["Relax NG schema input file/url missing"] - src _ = usage ["too many arguments"] - - help (Just _) = usage [] - help Nothing = return () - - --- ------------------------------------------------------------ --- test environment --- -{- -xmlFile :: String -xmlFile = "testCases/213/1.v.xml" - -schema :: [String] -schema = ["testCases/213/c.rng"] - -testValidator :: Attributes -> String -> String -> IOSArrow b Int -testValidator al src xmlFile - = readDocument al src - >>> propagateNamespaces - >>> simplificationStep1 - >>> simplificationStep2 [] [] - >>> simplificationStep3 - >>> simplificationStep4 - >>> simplificationStep5 - >>> simplificationStep6 - >>> simplificationStep7 - >>> simplificationStep8 - >>> cleanUp - >>> resetStates --- >>> perform (getErrors >>> writeDocument [(a_show_tree, "1")] "-") --- >>> perform (fromLA xmlTreeToPatternString >>> arrIO (\s -> hPutStrLn stdout (s ++ "\n\n"))) --- >>> perform (fromLA xmlTreeToPatternFormatedString >>> arrIO (\s -> hPutStrLn stdout (s ++ "\n\n"))) --- >>> perform (fromLA xmlTreeToPatternStringTree >>> arrIO (hPutStrLn stdout)) - >>> - ( getErrors - `orElse` - (validateXMLDoc [] xmlFile) - `orElse` - (root [] [(constA $ mkXTextTree "valid")]) - ) --- >>> writeDocument [(a_show_tree, "1")] "-" --- >>> writeDocument [(a_show_haskell, "1")] "-" - >>> getErrStatus --} diff --git a/examples/arrows/hrelaxng/Makefile b/examples/arrows/hrelaxng/Makefile deleted file mode 100644 --- a/examples/arrows/hrelaxng/Makefile +++ /dev/null @@ -1,77 +0,0 @@ -# $Id: Makefile,v 1.2 2005/09/30 14:41:44 hxml Exp $ - -HXT_HOME = ../../.. -PKGFLAGS = -GHCFLAGS = -Wall -O2 -GHC = ghc $(GHCFLAGS) $(PKGFLAGS) - -DIST = $(HXT_HOME)/dist/examples/arrows -DIST_DIR = $(DIST)/hrelaxng - -prog = ./HRelaxNG - -all : $(prog) - -prof : - ghc --make -o $(prog) -Wall -prof -auto-all -O -fglasgow-exts -ignore-package hxt -ignore-package HTTP -i../../../src $(prog).hs - -local : - ghc --make -o $(prog) $(GHCFLAGS) -fglasgow-exts -ignore-package hxt -i../../../src $(prog).hs - -$(prog) : $(prog).hs - $(GHC) --make -o $@ $< - -force : - $(GHC) --make -o $(prog) $(prog).hs - -test : $(prog) - @echo "===> Relax NG examples" ; echo ; sleep 1 - @$(MAKE) example1 example1a example2 example3 example5 - -example1 : - @echo "===> Validate a valid Relax NG schema with respect to a valid xml file" ; echo ; sleep 1 - $(prog) ./valid1.xml ./valid1.rng - @echo - -example1a : - @echo "a valid document" - $(prog) ./valid2.xml ./valid2.rng || true - @echo - -example1b : - @echo "===> 1. invalid document\n" - $(prog) ./inv2.xml ./valid2.rng || true - @echo "\n===> 2. invalid document\n" - $(prog) ./inv3.xml ./valid2.rng || true - @echo - -example2 : - @echo "===> Validate a valid Relax NG schema with respect to a invalid xml file" ; echo ; sleep 1 - $(prog) ./invalid1.xml ./valid1.rng || true - @echo - -example3 : - @echo "===> Incorrect Relax NG schema" ; echo ; sleep 1 - $(prog) ./valid1.xml ./invalid2.rng || true - @echo - -example4 : - @echo "===> Same example with \"--output-pattern-transformations\" option " ; echo ; sleep 1 - $(prog) --output-pattern-transformations ./valid1.xml ./invalid2.rng || true - @echo - -example5 : - @echo "===> Incorrect Relax NG schema with two errors" ; echo ; sleep 1 - $(prog) ./valid1.xml ./invalid3.rng || true - @echo - -EX = $(wildcard *valid*.xml *valid*.rng) - -dist : - [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) - cp $(EX) Makefile $(prog).hs $(DIST_DIR) - -clean : - rm -f $(prog) *.o *.hi - -# eof ------------------------------------------------------------ diff --git a/examples/arrows/hrelaxng/invalid1.xml b/examples/arrows/hrelaxng/invalid1.xml deleted file mode 100644 --- a/examples/arrows/hrelaxng/invalid1.xml +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/examples/arrows/hrelaxng/invalid2.rng b/examples/arrows/hrelaxng/invalid2.rng deleted file mode 100644 --- a/examples/arrows/hrelaxng/invalid2.rng +++ /dev/null @@ -1,13 +0,0 @@ - - - - - - - - - - - - diff --git a/examples/arrows/hrelaxng/invalid3.rng b/examples/arrows/hrelaxng/invalid3.rng deleted file mode 100644 --- a/examples/arrows/hrelaxng/invalid3.rng +++ /dev/null @@ -1,19 +0,0 @@ - - - - - - - - - - - - - - - - - - diff --git a/examples/arrows/hrelaxng/valid1.rng b/examples/arrows/hrelaxng/valid1.rng deleted file mode 100644 --- a/examples/arrows/hrelaxng/valid1.rng +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - diff --git a/examples/arrows/hrelaxng/valid1.xml b/examples/arrows/hrelaxng/valid1.xml deleted file mode 100644 --- a/examples/arrows/hrelaxng/valid1.xml +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/examples/arrows/hrelaxng/valid2.rng b/examples/arrows/hrelaxng/valid2.rng deleted file mode 100644 --- a/examples/arrows/hrelaxng/valid2.rng +++ /dev/null @@ -1,27 +0,0 @@ - - - - - - - - - - - 2 - 4 - - - - - - 4 - - - - - - - diff --git a/examples/arrows/hrelaxng/valid2.xml b/examples/arrows/hrelaxng/valid2.xml deleted file mode 100644 --- a/examples/arrows/hrelaxng/valid2.xml +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/examples/arrows/performance/GenDoc.hs b/examples/arrows/performance/GenDoc.hs --- a/examples/arrows/performance/GenDoc.hs +++ b/examples/arrows/performance/GenDoc.hs @@ -5,9 +5,10 @@ module Main where -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core +import Text.XML.HXT.TagSoup -import Text.XML.HXT.DOM.Unicode +import Data.String.Unicode ( unicodeToXmlEntity ) @@ -154,13 +155,13 @@ readDoc :: String -> IOSArrow b XmlTree readDoc src - = readDocument [ (a_tagsoup, v_1) - , (a_parse_xml, v_1) - , (a_remove_whitespace, v_1) - , (a_encoding, isoLatin1) - , (a_issue_warnings, v_0) - , (a_trace, v_1) - , (a_strict_input, v_0) + = readDocument [ withTagSoup + , withParseHTML no + , withRemoveWS yes + , withInputEncoding isoLatin1 + , withWarnings no + , withTrace 1 + , withStrictInput no ] src >>> processChildren (isElem `guards` this) diff --git a/examples/arrows/pickle/PickleTest.hs b/examples/arrows/pickle/PickleTest.hs --- a/examples/arrows/pickle/PickleTest.hs +++ b/examples/arrows/pickle/PickleTest.hs @@ -5,7 +5,7 @@ import System.Exit import Test.HUnit -import Text.XML.HXT.Arrow +import Text.XML.HXT.Core -- ------------------------------------------------------------ -- @@ -232,7 +232,7 @@ >>> writeDocumentToString [] -- XmlTree => String >>> - readFromString [(a_validate, v_0)] -- String => XmlTree + readFromString [ withValidate no ] -- String => XmlTree >>> arrL (maybeToList . unpickleDoc xpProgram) -- XmlTree => Program ) @@ -245,11 +245,11 @@ >>> arr (pickleDoc xpProgram) -- Program => XmlTree >>> - writeDocument [ (a_indent, v_1) -- XmlTree => formated external XML document + writeDocument [ withIndent yes -- XmlTree => formated external XML document ] "pickle.xml" >>> - readDocument [ (a_remove_whitespace, v_1) -- formated external XML document => XmlTree - , (a_validate, v_0) + readDocument [ withRemoveWS yes -- formated external XML document => XmlTree + , withValidate no ] "pickle.xml" >>> arrL (maybeToList . unpickleDoc xpProgram) -- XmlTree => Program @@ -263,12 +263,12 @@ ( constA p -- take the Program value >>> xpickleDocument xpProgram - [ (a_indent, v_1) -- Program => formated external XML document + [ withIndent yes -- Program => formated external XML document ] "pickle.xml" >>> xunpickleDocument xpProgram - [ (a_remove_whitespace, v_1) -- formated external XML document => Program - , (a_validate, v_0) + [ withRemoveWS yes -- formated external XML document => Program + , withValidate no ] "pickle.xml" ) res7 :: IO [Program] -- the most important case @@ -279,13 +279,13 @@ ( constA p -- take the Program value >>> xpickleDocument xpProgram - [ (a_indent, v_1) -- Program => formated external XML document - , (a_addDTD, v_1) + [ withIndent yes -- Program => formated external XML document + , withSysAttr a_addDTD v_1 -- with inline DTD ] "pickle.xml" >>> xunpickleDocument xpProgram - [ (a_remove_whitespace, v_1) -- formated external XML document => Program - , (a_validate, v_1) + [ withRemoveWS yes -- formated external XML document => Program + , withValidate yes ] "pickle.xml" ) diff --git a/hxt.cabal b/hxt.cabal --- a/hxt.cabal +++ b/hxt.cabal @@ -1,7 +1,7 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt -Version: 8.5.4 -Synopsis: A collection of tools for processing XML with Haskell. +Version: 9.0.0 +Synopsis: A collection of tools for processing XML with Haskell. Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell. The Haskell XML Toolbox uses a generic data model for representing XML documents, @@ -10,8 +10,11 @@ an XPath expression evaluator, an XSLT library, a RelaxNG schema validator and funtions for serialization and deserialization of user defined data. The library makes extensive use of the arrow approach for processing XML. - Since version 8.5 XPath and XSLT have been moved to separate packages hxt-xpath and hxt-xslt, - serialisation is in package hxt-binary + Since version 9 the toolbox is partitioned into various (sub-)packages. + This package contains the core functionality, + hxt-curl, hxt-tagsoup, hxt-relaxng, hxt-xpath, hxt-xslt, hxt-regex-xmlschema contain the extensions. + hxt-unicode contains encoding and decoding functions, + hxt-charproperties char properties for unicode and XML. License: OtherLicense License-file: LICENSE Author: Uwe Schmidt, Martin Schmidt, Torben Kuseler @@ -56,25 +59,14 @@ examples/arrows/hparser/namespace1.xml examples/arrows/hparser/valid1.rng examples/arrows/hparser/valid1.xml - examples/arrows/hrelaxng/.ghci - examples/arrows/hrelaxng/HRelaxNG.hs - examples/arrows/hrelaxng/invalid1.xml - examples/arrows/hrelaxng/invalid2.rng - examples/arrows/hrelaxng/invalid3.rng - examples/arrows/hrelaxng/Makefile - examples/arrows/hrelaxng/valid1.rng - examples/arrows/hrelaxng/valid1.xml - examples/arrows/hrelaxng/valid2.rng - examples/arrows/hrelaxng/valid2.xml examples/arrows/performance/GenDoc.hs examples/arrows/performance/Makefile examples/arrows/pickle/Makefile examples/arrows/pickle/PickleTest.hs - examples/arrows/RegexXMLSchema/Makefile - examples/arrows/RegexXMLSchema/REtest.hs library exposed-modules: + Control.Arrow.ArrowExc, Control.Arrow.ArrowIO, Control.Arrow.ArrowIf, Control.Arrow.ArrowList, @@ -88,10 +80,10 @@ Control.Arrow.StateListArrow, Data.AssocList, Data.Atom, - Data.Char.UTF8, + Data.Function.Selector, Data.Tree.Class, Data.Tree.NTree.TypeDefs, - Text.XML.HXT.Arrow, + Text.XML.HXT.Arrow.Binary, Text.XML.HXT.Arrow.DTDProcessing, Text.XML.HXT.Arrow.DocumentInput, Text.XML.HXT.Arrow.DocumentOutput, @@ -107,22 +99,27 @@ Text.XML.HXT.Arrow.ReadDocument, Text.XML.HXT.Arrow.WriteDocument, Text.XML.HXT.Arrow.XmlArrow, - Text.XML.HXT.Arrow.XmlIOStateArrow, + Text.XML.HXT.Arrow.XmlOptions, Text.XML.HXT.Arrow.XmlRegex, + Text.XML.HXT.Arrow.XmlState, + Text.XML.HXT.Arrow.XmlState.ErrorHandling, + Text.XML.HXT.Arrow.XmlState.MimeTypeTable, + Text.XML.HXT.Arrow.XmlState.RunIOStateArrow, + Text.XML.HXT.Arrow.XmlState.TraceHandling, + Text.XML.HXT.Arrow.XmlState.TypeDefs, + Text.XML.HXT.Arrow.XmlState.URIHandling, + Text.XML.HXT.Arrow.XmlState.SystemConfig, + Text.XML.HXT.Core, Text.XML.HXT.DOM.FormatXmlTree, Text.XML.HXT.DOM.Interface, - Text.XML.HXT.DOM.IsoLatinTables, Text.XML.HXT.DOM.MimeTypeDefaults, Text.XML.HXT.DOM.MimeTypes, Text.XML.HXT.DOM.QualifiedName, Text.XML.HXT.DOM.ShowXml, Text.XML.HXT.DOM.TypeDefs, - Text.XML.HXT.DOM.UTF8Decoding, - Text.XML.HXT.DOM.Unicode, Text.XML.HXT.DOM.Util, Text.XML.HXT.DOM.XmlKeywords, Text.XML.HXT.DOM.XmlNode, - Text.XML.HXT.DOM.XmlOptions, Text.XML.HXT.DTDValidation.AttributeValueValidation, Text.XML.HXT.DTDValidation.DTDValidation, Text.XML.HXT.DTDValidation.DocTransformation, @@ -133,10 +130,8 @@ Text.XML.HXT.DTDValidation.Validation, Text.XML.HXT.DTDValidation.XmlRE, Text.XML.HXT.IO.GetFILE, - Text.XML.HXT.IO.GetHTTPLibCurl, Text.XML.HXT.Parser.HtmlParsec, Text.XML.HXT.Parser.ProtocolHandlerUtil, - Text.XML.HXT.Parser.TagSoup, Text.XML.HXT.Parser.XhtmlEntities, Text.XML.HXT.Parser.XmlCharParser, Text.XML.HXT.Parser.XmlDTDParser, @@ -144,27 +139,7 @@ Text.XML.HXT.Parser.XmlEntities, Text.XML.HXT.Parser.XmlParsec, Text.XML.HXT.Parser.XmlTokenParser, - Text.XML.HXT.RelaxNG, - Text.XML.HXT.RelaxNG.BasicArrows, - Text.XML.HXT.RelaxNG.CreatePattern, - Text.XML.HXT.RelaxNG.DataTypeLibMysql, - Text.XML.HXT.RelaxNG.DataTypeLibUtils, - Text.XML.HXT.RelaxNG.DataTypeLibraries, - Text.XML.HXT.RelaxNG.DataTypes, - Text.XML.HXT.RelaxNG.PatternFunctions, - Text.XML.HXT.RelaxNG.PatternToString, - Text.XML.HXT.RelaxNG.Schema, - Text.XML.HXT.RelaxNG.SchemaGrammar, - Text.XML.HXT.RelaxNG.Simplification, - Text.XML.HXT.RelaxNG.Unicode.Blocks, - Text.XML.HXT.RelaxNG.Unicode.CharProps, - Text.XML.HXT.RelaxNG.Utils, - Text.XML.HXT.RelaxNG.Validation, - Text.XML.HXT.RelaxNG.Validator, - Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C, - Text.XML.HXT.RelaxNG.XmlSchema.Regex, - Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch, - Text.XML.HXT.RelaxNG.XmlSchema.RegexParser, + Text.XML.HXT.XMLSchema.DataTypeLibW3CNames, Text.XML.HXT.Version hs-source-dirs: src @@ -183,5 +158,7 @@ network >= 2.1 && < 3, deepseq >= 1.1 && < 2, bytestring >= 0.9 && < 1, - tagsoup >= 0.10 && < 0.11, - curl >= 1.3 && < 2 + binary >= 0.5 && < 1, + hxt-charproperties >= 9 && < 10, + hxt-unicode >= 9 && < 10, + hxt-regex-xmlschema >= 9 && < 10 diff --git a/src/Control/Arrow/ArrowExc.hs b/src/Control/Arrow/ArrowExc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/ArrowExc.hs @@ -0,0 +1,38 @@ +-- ------------------------------------------------------------ + +{- | + Module : Control.Arrow.ArrowExc + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) + Stability : experimental + Portability: not portable + + The exception arrow class + +-} + +-- ------------------------------------------------------------ + +module Control.Arrow.ArrowExc + ( ArrowExc(..) + ) +where + +import Control.Arrow +import Control.Arrow.ArrowIO + +import Control.Exception ( SomeException + ) + +class (Arrow a, ArrowChoice a, ArrowZero a, ArrowIO a) => ArrowExc a where + tryA :: a b c -> a b (Either SomeException c) + + catchA :: a b c -> a SomeException c -> a b c + catchA f h = tryA f + >>> + ( h ||| returnA ) + + +-- ------------------------------------------------------------ diff --git a/src/Control/Arrow/ArrowIO.hs b/src/Control/Arrow/ArrowIO.hs --- a/src/Control/Arrow/ArrowIO.hs +++ b/src/Control/Arrow/ArrowIO.hs @@ -8,9 +8,8 @@ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: ArrowIO.hs,v 1.6 2005/09/02 17:09:39 hxml Exp $ -Lifting of IO actions to arrows + Lifting of IO actions to arrows -} diff --git a/src/Control/Arrow/ArrowIf.hs b/src/Control/Arrow/ArrowIf.hs --- a/src/Control/Arrow/ArrowIf.hs +++ b/src/Control/Arrow/ArrowIf.hs @@ -8,14 +8,12 @@ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: ArrowIf.hs,v 1.8 2006/05/04 14:17:53 hxml Exp $ -Conditionals for List Arrows - -This module defines conditional combinators for list arrows. + Conditionals for List Arrows -The empty list as result represents False, none empty lists True. + This module defines conditional combinators for list arrows. + The empty list as result represents False, none empty lists True. -} -- ------------------------------------------------------------ diff --git a/src/Control/Arrow/ArrowList.hs b/src/Control/Arrow/ArrowList.hs --- a/src/Control/Arrow/ArrowList.hs +++ b/src/Control/Arrow/ArrowList.hs @@ -8,17 +8,16 @@ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: ArrowList.hs,v 1.11 2006/06/01 12:59:04 hxml Exp $ -The List Arrow Class + The list arrow class -This module defines the interface for list arrows. + This module defines the interface for list arrows. -A list arrow is a function, that gives a list of results -for a given argument. A single element result represents a normal function. -An empty list oven indicates, the function is undefined for the given argument. -The empty list may also represent False, none empty lists True. -A list with more than one element gives all results for a nondeterministic function. + A list arrow is a function, that gives a list of results + for a given argument. A single element result represents a normal function. + An empty list oven indicates, the function is undefined for the given argument. + The empty list may also represent False, none empty lists True. + A list with more than one element gives all results for a nondeterministic function. -} diff --git a/src/Control/Arrow/ArrowState.hs b/src/Control/Arrow/ArrowState.hs --- a/src/Control/Arrow/ArrowState.hs +++ b/src/Control/Arrow/ArrowState.hs @@ -9,7 +9,7 @@ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) Stability : experimental - Portability: multy parameter classes and functional depenedencies required + Portability: multi parameter classes and functional depenedencies required Arrows for managing an explicit state diff --git a/src/Control/Arrow/ArrowTree.hs b/src/Control/Arrow/ArrowTree.hs --- a/src/Control/Arrow/ArrowTree.hs +++ b/src/Control/Arrow/ArrowTree.hs @@ -2,19 +2,17 @@ {- | Module : Control.Arrow.ArrowTree - Copyright : Copyright (C) 2005 Uwe Schmidt + Copyright : Copyright (C) 2010 Uwe Schmidt License : MIT Maintainer : Uwe Schmidt (uwe\@fh-wedel.de) - Stability : experimental + Stability : stable Portability: portable - Version : $Id: ArrowTree.hs,v 1.12 2006/11/30 16:05:24 hxml Exp $ -List arrows for tree processing. - -Trees that implement the "Data.Tree.Class" interface, can be processed -with these arrows. + List arrows for tree processing. + Trees that implement the "Data.Tree.Class" interface, can be processed + with these arrows. -} -- ------------------------------------------------------------ @@ -181,7 +179,7 @@ -- The search is performed top down. All nodes of the tree are searched, even within the -- subtrees of trees for which the predicate holds. -- - -- example: @ multy isHtmlTable @ selects all table elements, even nested ones. + -- example: @ multi isHtmlTable @ selects all table elements, even nested ones. multi :: Tree t => a (t b) c -> a (t b) c multi f = f -- combine result for root diff --git a/src/Control/Arrow/IOListArrow.hs b/src/Control/Arrow/IOListArrow.hs --- a/src/Control/Arrow/IOListArrow.hs +++ b/src/Control/Arrow/IOListArrow.hs @@ -23,14 +23,18 @@ import Control.Category -import Control.Arrow -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList -import Control.Arrow.ArrowNF -import Control.Arrow.ArrowTree -import Control.Arrow.ArrowIO +import Control.Arrow +import Control.Arrow.ArrowExc +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Arrow.ArrowNF +import Control.Arrow.ArrowTree -import Control.DeepSeq +import Control.DeepSeq +import Control.Exception ( SomeException + , try + ) -- ------------------------------------------------------------ @@ -116,6 +120,16 @@ arrIO cmd = IOLA $ \x -> do res <- cmd x return [res] + +instance ArrowExc IOLA where + tryA f = IOLA $ \ x -> do + res <- try' $ runIOLA f x + return $ case res of + Left er -> [Left er] + Right ys -> [Right x' | x' <- ys] + where + try' :: IO a -> IO (Either SomeException a) + try' = try instance ArrowIOIf IOLA where isIOA p = IOLA $ \x -> do diff --git a/src/Control/Arrow/IOStateListArrow.hs b/src/Control/Arrow/IOStateListArrow.hs --- a/src/Control/Arrow/IOStateListArrow.hs +++ b/src/Control/Arrow/IOStateListArrow.hs @@ -24,19 +24,23 @@ ) where -import Prelude hiding (id, (.)) +import Prelude hiding (id, (.)) -import Control.Category +import Control.Category -import Control.Arrow -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowList -import Control.Arrow.ArrowNF -import Control.Arrow.ArrowTree -import Control.Arrow.ArrowState +import Control.Arrow +import Control.Arrow.ArrowExc +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Arrow.ArrowNF +import Control.Arrow.ArrowTree +import Control.Arrow.ArrowState -import Control.DeepSeq +import Control.DeepSeq +import Control.Exception ( SomeException + , try + ) -- ------------------------------------------------------------ @@ -144,6 +148,16 @@ arrIO cmd = IOSLA $ \ s x -> do res <- cmd x return (s, [res]) + +instance ArrowExc (IOSLA s) where + tryA f = IOSLA $ \ s x -> do + res <- try' $ runIOSLA f s x + return $ case res of + Left er -> (s, [Left er]) + Right (s1, ys) -> (s1, [Right x' | x' <- ys]) + where + try' :: IO a -> IO (Either SomeException a) + try' = try instance ArrowIOIf (IOSLA s) where isIOA p = IOSLA $ \ s x -> do diff --git a/src/Control/Arrow/ListArrows.hs b/src/Control/Arrow/ListArrows.hs --- a/src/Control/Arrow/ListArrows.hs +++ b/src/Control/Arrow/ListArrows.hs @@ -17,12 +17,13 @@ module Control.Arrow.ListArrows ( module Control.Arrow -- arrow classes - , module Control.Arrow.ArrowList + , module Control.Arrow.ArrowExc , module Control.Arrow.ArrowIf + , module Control.Arrow.ArrowIO + , module Control.Arrow.ArrowList , module Control.Arrow.ArrowNF , module Control.Arrow.ArrowState , module Control.Arrow.ArrowTree - , module Control.Arrow.ArrowIO , module Control.Arrow.ListArrow -- arrow types , module Control.Arrow.StateListArrow @@ -32,6 +33,7 @@ where import Control.Arrow -- arrow classes +import Control.Arrow.ArrowExc import Control.Arrow.ArrowList import Control.Arrow.ArrowIf import Control.Arrow.ArrowNF diff --git a/src/Data/AssocList.hs b/src/Data/AssocList.hs --- a/src/Data/AssocList.hs +++ b/src/Data/AssocList.hs @@ -1,8 +1,20 @@ --- | --- simple key value assocciation list --- implemented as unordered list of pairs --- --- Version : $Id: AssocList.hs,v 1.2 2005/05/27 13:15:23 hxml Exp $ +-- ------------------------------------------------------------ + +{- | + Module : Data.AssocList + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : stable + Portability: portable + + Simple key value assocciation list + implemented as unordered list of pairs + +-} + +-- ------------------------------------------------------------ module Data.AssocList ( module Data.AssocList diff --git a/src/Data/Atom.hs b/src/Data/Atom.hs --- a/src/Data/Atom.hs +++ b/src/Data/Atom.hs @@ -65,12 +65,11 @@ import Data.ByteString.Internal ( toForeignPtr, c2w, w2c ) import Data.ByteString ( ByteString, pack, unpack ) import qualified Data.Map as M +import Data.String.UTF8Decoding ( decodeUtf8 ) +import Data.String.Unicode ( unicodeToUtf8 ) import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) - -import Text.XML.HXT.DOM.Unicode ( unicodeToUtf8 ) -import Text.XML.HXT.DOM.UTF8Decoding ( decodeUtf8 ) -- ------------------------------------------------------------ diff --git a/src/Data/Char/UTF8.hs b/src/Data/Char/UTF8.hs deleted file mode 100644 --- a/src/Data/Char/UTF8.hs +++ /dev/null @@ -1,363 +0,0 @@ -{- - -Copyright (c) 2002, members of the Haskell Internationalisation Working -Group All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -* Neither the name of the Haskell Internationalisation Working Group nor - the names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -This module provides lazy stream encoding/decoding facilities for UTF-8, -the Unicode Transformation Format with 8-bit words. - -2002-09-02 Sven Moritz Hallberg - --} - -{- - -2007-04-30 Henning Thielemann: -Slight changes to make decode lazy. -The calls of 'reverse' in the original version have broken laziness -and thus had memory leaks. - --} - -module Data.Char.UTF8 - ( encode, decode, - decodeEmbedErrors, - encodeOne, decodeOne, - Error, -- Haddock does not want to document signatures with private types - -- these functions should be moved to a utility module - ) where - -import Data.Char (ord, chr) -import Data.Word (Word8, Word16, Word32) -import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) - -import Data.List (unfoldr) - -import Text.XML.HXT.DOM.Util (partitionEither, swap, toMaybe) - - - --- - UTF-8 in General - - --- Adapted from the Unicode standard, version 3.2, --- Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings): - --- Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte --- 000000000xxxxxxx 0xxxxxxx --- 00000yyyyyxxxxxx 110yyyyy 10xxxxxx --- zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx --- 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx - --- Also from the Unicode standard, version 3.2, --- Table 3.1B "Legal UTF-8 Byte Sequences": - --- Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte --- U+0000..U+007F 00..7F --- U+0080..U+07FF C2..DF 80..BF --- U+0800..U+0FFF E0 A0..BF 80..BF --- U+1000..U+CFFF E1..EC 80..BF 80..BF --- U+D000..U+D7FF ED 80..9F 80..BF --- U+D800..U+DFFF ill-formed --- U+E000..U+FFFF EE..EF 80..BF 80..BF --- U+10000..U+3FFFF F0 90..BF 80..BF 80..BF --- U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF --- U+100000..U+10FFFF F4 80..8F 80..BF 80..BF - - - --- - Encoding Functions - - --- Must the encoder ensure that no illegal byte sequences are output or --- can we trust the Haskell system to supply only legal values? --- For now I include error case for the surrogate values U+D800..U+DFFF and --- out-of-range scalars. - --- The function is pretty much a transscript of table 3.1B with error checks. --- It dispatches the actual encoding to functions specific to the number of --- required bytes. - -encodeOne :: Char -> [Word8] -encodeOne c - -- The report guarantees in (6.1.2) that this won't happen: - -- | n < 0 = error "encodeUTF8: ord returned a negative value" - | n < 0x0080 = encodeOne_onebyte n8 - | n < 0x0800 = encodeOne_twobyte n16 - | n < 0xD800 = encodeOne_threebyte n16 - | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value" - | n < 0x10000 = encodeOne_threebyte n16 - -- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1. - | n < 0x10FFFF = encodeOne_fourbyte n32 - | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF" - where - n = ord c :: Int - n8 = fromIntegral n :: Word8 - n16 = fromIntegral n :: Word16 - n32 = fromIntegral n :: Word32 - - --- With the above, a stream decoder is trivial: - -encode :: [Char] -> [Word8] -encode = concatMap encodeOne - - --- Now follow the individual encoders for certain numbers of bytes... --- _ --- / | __ ___ __ __ --- / ^| // /__/ // // --- /.==| \\ //_ // // --- It's // || // \_/_//_//_ and it's here to stay! - -encodeOne_onebyte :: Word8 -> [Word8] -encodeOne_onebyte cp = [cp] - - --- 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx - -encodeOne_twobyte :: Word16 -> [Word8] -encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)] - where - xs, ys :: Word8 - ys = fromIntegral (shiftR cp 6) - xs = (fromIntegral cp) .&. 0x3F - - --- zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx - -encodeOne_threebyte :: Word16 -> [Word8] -encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)] - where - xs, ys, zs :: Word8 - xs = (fromIntegral cp) .&. 0x3F - ys = (fromIntegral (shiftR cp 6)) .&. 0x3F - zs = fromIntegral (shiftR cp 12) - - --- 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx - -encodeOne_fourbyte :: Word32 -> [Word8] -encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs] - where - xs, ys, zs, us :: Word8 - xs = (fromIntegral cp) .&. 0x3F - ys = (fromIntegral (shiftR cp 6)) .&. 0x3F - zs = (fromIntegral (shiftR cp 12)) .&. 0x3F - us = fromIntegral (shiftR cp 18) - - - --- - Decoding - - --- The decoding is a bit more involved. The byte sequence could contain all --- sorts of corruptions. The user must be able to either notice or ignore these --- errors. - --- I will first look at the decoding of a single character. The process --- consumes a certain number of bytes from the input. It returns the --- remaining input and either an error and the index of its occurance in the --- byte sequence or the decoded character. - -data Error - --- The first byte in a sequence starts with either zero, two, three, or four --- ones and one zero to indicate the length of the sequence. If it doesn't, --- it is invalid. It is dropped and the next byte interpreted as the start --- of a new sequence. - - = InvalidFirstByte - --- All bytes in the sequence except the first match the bit pattern 10xxxxxx. --- If one doesn't, it is invalid. The sequence up to that point is dropped --- and the "invalid" byte interpreted as the start of a new sequence. The error --- includes the length of the partial sequence and the number of expected bytes. - - | InvalidLaterByte Int -- the byte at relative index n was invalid - --- If a sequence ends prematurely, it has been truncated. It dropped and --- decoding stops. The error reports the actual and expected lengths of the --- sequence. - - | Truncated Int Int -- only n of m expected bytes were present - --- Some sequences would represent code points which would be encoded as a --- shorter sequence by a conformant encoder. Such non-shortest sequences are --- considered erroneous and dropped. The error reports the actual and --- expected number of bytes used. - - | NonShortest Int Int -- n instead of m bytes were used - --- Unicode code points are in the range of [0..0x10FFFF]. Any values outside --- of those bounds are simply invalid. - - | ValueOutOfBounds - --- There is no such thing as "surrogate pairs" any more in UTF-8. The --- corresponding code points now form illegal byte sequences. - - | Surrogate - deriving (Show, Eq) - - --- Second, third, and fourth bytes share the common requirement to start --- with the bit sequence 10. So, here's the function to check that property. - -first_bits_not_10 :: Word8 -> Bool -first_bits_not_10 b - | (b.&.0xC0) /= 0x80 = True - | otherwise = False - - --- Erm, OK, the single-character decoding function's return type is a bit --- longish. It is a tripel: - --- - The first component contains the decoded character or an error --- if the byte sequence was erroneous. --- - The second component contains the number of bytes that were consumed --- from the input. --- - The third component contains the remaining bytes of input. - -decodeOne :: [Word8] -> (Either Error Char, Int, [Word8]) -decodeOne bs@(b1:rest) - | b1 < 0x80 = decodeOne_onebyte bs - | b1 < 0xC0 = (Left InvalidFirstByte, 1, rest) - | b1 < 0xE0 = decodeOne_twobyte bs - | b1 < 0xF0 = decodeOne_threebyte bs - | b1 < 0xF5 = decodeOne_fourbyte bs - | otherwise = (Left ValueOutOfBounds, 1, rest) -decodeOne [] = error "UTF8.decodeOne: No input" - - --- 0xxxxxxx -> 000000000xxxxxxx - -decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8]) -decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs) -decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)" - -cpToChar :: Integral a => a -> Char -cpToChar = chr . fromIntegral - - --- 110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx - -decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8]) -decodeOne_twobyte (_:[]) - = (Left (Truncated 1 2), 1, []) -decodeOne_twobyte (b1:b2:bs) - | b1 < 0xC2 = (Left (NonShortest 2 1), 2, bs) - | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs)) - | otherwise = (Right (cpToChar result), 2, bs) - where - xs, ys, result :: Word32 - xs = fromIntegral (b2.&.0x3F) - ys = fromIntegral (b1.&.0x1F) - result = shiftL ys 6 .|. xs -decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)" - - --- 1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx - -decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8]) -decodeOne_threebyte (_:[]) = threebyte_truncated 1 -decodeOne_threebyte (_:_:[]) = threebyte_truncated 2 -decodeOne_threebyte bs@(b1:b2:b3:rest) - | first_bits_not_10 b2 - = (Left (InvalidLaterByte 1), 1, drop 1 bs) - | first_bits_not_10 b3 - = (Left (InvalidLaterByte 2), 2, drop 2 bs) - | result < 0x0080 - = (Left (NonShortest 3 1), 3, rest) - | result < 0x0800 - = (Left (NonShortest 3 2), 3, rest) - | result >= 0xD800 && result < 0xE000 - = (Left Surrogate, 3, rest) - | otherwise - = (Right (cpToChar result), 3, rest) - where - xs, ys, zs, result :: Word32 - xs = fromIntegral (b3.&.0x3F) - ys = fromIntegral (b2.&.0x3F) - zs = fromIntegral (b1.&.0x0F) - result = shiftL zs 12 .|. shiftL ys 6 .|. xs -decodeOne_threebyte[] - = error "UTF8.decodeOne_threebyte: No input (can't happen)" - -threebyte_truncated :: Int -> (Either Error Char, Int, [Word8]) -threebyte_truncated n = (Left (Truncated n 3), n, []) - - --- 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx - -decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8]) -decodeOne_fourbyte (_:[]) = fourbyte_truncated 1 -decodeOne_fourbyte (_:_:[]) = fourbyte_truncated 2 -decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3 -decodeOne_fourbyte bs@(b1:b2:b3:b4:rest) - | first_bits_not_10 b2 - = (Left (InvalidLaterByte 1), 1, drop 1 bs) - | first_bits_not_10 b3 - = (Left (InvalidLaterByte 2), 2, drop 2 bs) - | first_bits_not_10 b4 - = (Left (InvalidLaterByte 3), 3, drop 3 bs) - | result < 0x0080 - = (Left (NonShortest 4 1), 4, rest) - | result < 0x0800 - = (Left (NonShortest 4 2), 4, rest) - | result < 0x10000 - = (Left (NonShortest 4 3), 4, rest) - | result > 0x10FFFF - = (Left ValueOutOfBounds, 4, rest) - | otherwise - = (Right (cpToChar result), 4, rest) - where - xs, ys, zs, us, result :: Word32 - xs = fromIntegral (b4 .&. 0x3F) - ys = fromIntegral (b3 .&. 0x3F) - zs = fromIntegral (b2 .&. 0x3F) - us = fromIntegral (b1 .&. 0x07) - result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18 -decodeOne_fourbyte[] - = error "UTF8.decodeOne_fourbyte: No input (can't happen)" - -fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8]) -fourbyte_truncated n = (Left (Truncated n 4), n, []) - - --- The decoder examines all input, recording decoded characters as well as --- error-index pairs along the way. - -decode :: [Word8] -> ([Char], [(Error,Int)]) -decode = swap . partitionEither . decodeEmbedErrors - -decodeEmbedErrors :: [Word8] -> [Either (Error,Int) Char] -decodeEmbedErrors = - unfoldr (\(pos,xs) -> - toMaybe - (not $ null xs) - (let (c,n,rest) = decodeOne xs - in (either (\err -> Left (err,pos)) Right c, - (pos+n,rest)))) . - (,) 0 diff --git a/src/Data/Function/Selector.hs b/src/Data/Function/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function/Selector.hs @@ -0,0 +1,139 @@ +{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-} + +module Data.Function.Selector +where + +import Prelude hiding (id,(.)) + +import Control.Arrow +import Control.Category + +infixr 3 .&&&. + +-- ------------------------------------------------------------ + +-- | A Selector is a pair of an access function and a modifying function +-- for reading and updating parts of a composite type + +data Selector s a = S { getS :: s -> a + , setS :: a -> s -> s + } + +chgS :: Selector s a -> (a -> a) -> (s -> s) +chgS sel f s = setS sel x s + where + x = f . getS sel $ s + +chgM :: (Monad m) => Selector s a -> (a -> m a) -> (s -> m s) +chgM sel f s = do + y <- f x + return $ setS sel y s + where + x = getS sel $ s + +-- | Alias for constructor S + +mkSelector :: (s -> a) -> (a -> s -> s) -> Selector s a +mkSelector = S + +-- (.), (>>>), (<<<) + +instance Category Selector where + id = S { getS = id + , setS = const + } + (S g2 s2) . (S g1 s1) = S { getS = g2 . g1 + , setS = \ x s -> + let x1 = g1 s in + let x1' = s2 x x1 in + s1 x1' s + } + +idS :: Selector s s +idS = id + +(.&&&.) :: Selector s a -> Selector s b -> Selector s (a, b) +(.&&&.) (S g1 s1) (S g2 s2) = S { getS = g1 &&& g2 + , setS = \ (x, y) -> s2 y . s1 x + } + +-- ------------------------------------------------------------ +-- TODO: delete theses +{- +subS :: Selector b c -> Selector a b -> Selector a c +subS = (.) + +pairS :: Selector s a -> Selector s b -> Selector s (a, b) +pairS = (.&&&.) + +chgS :: Selector s a -> (a -> a) -> (s -> s) +chgS = update + +putS :: Selector s a -> a -> (s -> s) +putS = setS + +-} +-- ------------------------------------------------------------ +{- +type Selector s a = (s -> a, a -> s -> s) + +subS :: Selector b c -> Selector a b -> Selector a c +subS (g2, s2) (g1, s1) = ( g2 . g1 + , s1s2 + ) + where + s1s2 x s = s' + where + x1 = g1 s + x1' = s2 x x1 + s' = s1 x1' s + +pairS :: Selector s a -> Selector s b -> Selector s (a, b) +pairS (g1, s1) (g2, s2) = ( g1 &&& g2 + , \ (x, y) -> s2 y . s1 x + ) + +chgS :: Selector s a -> (a -> a) -> (s -> s) +chgS (g, s) f x = s (f (g x)) x + +getS :: Selector s a -> s -> a +getS = fst -- getS (g, _s) x = g x + +putS :: Selector s a -> a -> (s -> s) +putS s v = chgS s (const v) + +idS :: Selector s s +idS = (id, const) +-} +-- ------------------------------------------------------------ + +-- | Selectors for pairs and 3-tuples: comp1, comp2, comp3, +-- this can be extended to n-tuples + +class Comp1 s a | s -> a where comp1 :: Selector s a +class Comp2 s a | s -> a where comp2 :: Selector s a +class Comp3 s a | s -> a where comp3 :: Selector s a + + +instance Comp1 (a, b) a where comp1 = S { getS = fst + , setS = \ x1 (_, x2) -> (x1, x2) + } + +instance Comp2 (a, b) b where comp2 = S { getS = snd + , setS = \ x2 (x1, _) -> (x1, x2) + } + +instance Comp1 (a, b, c) a where comp1 = S { getS = \ (x1, _, _) -> x1 + , setS = \ x1 (_, x2, x3) -> (x1, x2, x3) + } + +instance Comp2 (a, b, c) b where comp2 = S { getS = \ (_, x2, _) -> x2 + , setS = \ x2 (x1, _, x3) -> (x1, x2, x3) + } + +instance Comp3 (a, b, c) c where comp3 = S { getS = \ (_, _, x3) -> x3 + , setS = \ x3 (x1, x2, _) -> (x1, x2, x3) + } + +-- ------------------------------------------------------------ + diff --git a/src/Data/Tree/NTree/TypeDefs.hs b/src/Data/Tree/NTree/TypeDefs.hs --- a/src/Data/Tree/NTree/TypeDefs.hs +++ b/src/Data/Tree/NTree/TypeDefs.hs @@ -27,6 +27,7 @@ import Control.DeepSeq +import Data.Binary import Data.Tree.Class import Data.Typeable @@ -50,6 +51,13 @@ instance (NFData a) => NFData (NTree a) where rnf (NTree n cl) = rnf n `seq` rnf cl + +instance (Binary a) => Binary (NTree a) where + put (NTree n cs) = put n >> put cs + get = do + n <- get + cs <- get + return (NTree n cs) -- | NTree implements class Functor diff --git a/src/Text/XML/HXT/Arrow.hs b/src/Text/XML/HXT/Arrow.hs deleted file mode 100644 --- a/src/Text/XML/HXT/Arrow.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ------------------------------------------------------------ - -{- | - Module : Text.XML.HXT.Arrow - Copyright : Copyright (C) 2006-2010 Uwe Schmidt - License : MIT - - Maintainer : Uwe Schmidt (uwe@fh-wedel.de) - Stability : stable - Portability: portable - - The HXT arrow interface - - The application programming interface to the arrow modules of the Haskell XML Toolbox. - This module exports all important arrows for input, output, parsing, validating and transforming XML. - It also exports all basic datatypes and functions of the toolbox. - --} - --- ------------------------------------------------------------ - -module Text.XML.HXT.Arrow - ( module Control.Arrow.ListArrows - - , module Text.XML.HXT.DOM.Interface - - , module Text.XML.HXT.Arrow.XmlArrow - , module Text.XML.HXT.Arrow.XmlIOStateArrow - - , module Text.XML.HXT.Arrow.DocumentInput - , module Text.XML.HXT.Arrow.DocumentOutput - , module Text.XML.HXT.Arrow.Edit - , module Text.XML.HXT.Arrow.GeneralEntitySubstitution - , module Text.XML.HXT.Arrow.Namespace - , module Text.XML.HXT.Arrow.ProcessDocument - , module Text.XML.HXT.Arrow.ReadDocument - , module Text.XML.HXT.Arrow.WriteDocument - , module Text.XML.HXT.Arrow.Pickle - - , module Text.XML.HXT.Version - ) -where - -import Control.Arrow.ListArrows -- arrow classes - -import Data.Atom () -- import this explicitly - -import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.DocumentInput -import Text.XML.HXT.Arrow.DocumentOutput -import Text.XML.HXT.Arrow.Edit -import Text.XML.HXT.Arrow.GeneralEntitySubstitution -import Text.XML.HXT.Arrow.Namespace -import Text.XML.HXT.Arrow.Pickle -import Text.XML.HXT.Arrow.ProcessDocument -import Text.XML.HXT.Arrow.ReadDocument -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.XmlRegex () -- import this explicitly - -import Text.XML.HXT.Version - --- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/Binary.hs b/src/Text/XML/HXT/Arrow/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/HXT/Arrow/Binary.hs @@ -0,0 +1,69 @@ +-- ------------------------------------------------------------ + +{- | + Module : Text.XML.HXT.Arrow.Binary + Copyright : Copyright (C) 2008 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: portable + + De-/Serialisation arrows for XmlTrees and other arbitrary values with a Binary instance +-} + +-- ------------------------------------------------------------ + +module Text.XML.HXT.Arrow.Binary + ( readBinaryValue + , writeBinaryValue + ) +where + +import Control.Arrow () +import Control.Arrow.ArrowExc +import Control.Arrow.ArrowList +import Control.Arrow.ArrowIO + +import Control.DeepSeq + +import Data.Binary +import qualified Data.ByteString.Lazy as B + +import Text.XML.HXT.Arrow.XmlState.ErrorHandling +import Text.XML.HXT.Arrow.XmlState.TypeDefs + +-- ------------------------------------------------------------ + +readBinaryValue :: (NFData a, Binary a) => String -> IOStateArrow s b a +readBinaryValue file = flip decodeBinaryValue file $< getSysVar theBinaryDeCompression + +-- | Read a serialied value from a file, optionally decompress it and decode the value +-- In case of an error, the error message is issued and the arrow fails + +decodeBinaryValue :: (NFData a, Binary a) => DeCompressionFct -> String -> IOStateArrow s b a +decodeBinaryValue decompress file + = arrIO0 ( do + r <- dec + rnf r `seq` return r + ) + `catchA` + issueExc "readBinaryValue" + where + dec = B.readFile file >>= return . decode . decompress + +-- | Serialize a value, optionally compress it, and write it to a file. +-- In case of an error, the error message is issued and the arrow fails + +writeBinaryValue :: (Binary a) => String -> IOStateArrow s a () +writeBinaryValue file = flip encodeBinaryValue file $< getSysVar theBinaryCompression + +encodeBinaryValue :: (Binary a) => CompressionFct -> String -> IOStateArrow s a () +encodeBinaryValue compress file + = arrIO enc + `catchA` + issueExc "writeBinaryXmlTree" + where + enc = B.writeFile file . compress . encode + +-- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/DTDProcessing.hs b/src/Text/XML/HXT/Arrow/DTDProcessing.hs --- a/src/Text/XML/HXT/Arrow/DTDProcessing.hs +++ b/src/Text/XML/HXT/Arrow/DTDProcessing.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: DTDProcessing.hs,v 1.9 2006/05/11 14:47:19 hxml Exp $ DTD processing function for including external parts of a DTD @@ -34,7 +33,7 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.Arrow.ParserInterface ( parseXmlDTDdecl @@ -127,7 +126,7 @@ processRoot = ( traceMsg 1 ("processDTD: process parameter entities") >>> - setParamString a_standalone "" + setSysAttrString a_standalone "" >>> ( addDocType `whenNot` diff --git a/src/Text/XML/HXT/Arrow/DocumentInput.hs b/src/Text/XML/HXT/Arrow/DocumentInput.hs --- a/src/Text/XML/HXT/Arrow/DocumentInput.hs +++ b/src/Text/XML/HXT/Arrow/DocumentInput.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id$ State arrows for document input -} @@ -22,36 +21,37 @@ , getEncoding , getTextEncoding , decodeDocument + , addInputError ) where -import Control.Arrow -- arrow classes -import Control.Arrow.ArrowList -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowTree -import Control.Arrow.ArrowIO -import Control.Arrow.ListArrow - -import Data.List ( isPrefixOf ) - -import System.FilePath ( takeExtension ) +import Control.Arrow -- arrow classes +import Control.Arrow.ArrowList +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowTree +import Control.Arrow.ArrowIO +import Control.Arrow.ListArrow -import Text.XML.HXT.DOM.Unicode ( getDecodingFct +import Data.List ( isPrefixOf ) +import Data.String.Unicode ( getDecodingFct , guessEncoding , normalizeNL ) +import System.FilePath ( takeExtension ) + import qualified Text.XML.HXT.IO.GetFILE as FILE -import qualified Text.XML.HXT.IO.GetHTTPLibCurl as LibCURL -import Text.XML.HXT.DOM.Interface +import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.ParserInterface ( parseXmlDocEncodingSpec +import Text.XML.HXT.Arrow.ParserInterface + ( parseXmlDocEncodingSpec , parseXmlEntityEncodingSpec , removeEncodingSpec ) -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs -- ---------------------------------------------------------- @@ -101,10 +101,7 @@ getFileContents :: IOStateArrow s XmlTree XmlTree getFileContents - = applyA ( ( ( getAttrValue a_strict_input - >>> - arr isTrueValue - ) + = applyA ( ( getSysVar theStrictInput &&& ( getAttrValue transferURI >>> @@ -116,7 +113,7 @@ >>> arrIO (uncurry FILE.getCont) >>> - ( arr (uncurry addError) -- io error occured + ( arr (uncurry addInputError) -- io error occured ||| arr addTxtContent -- content read ) @@ -126,20 +123,18 @@ getStdinContents :: IOStateArrow s XmlTree XmlTree getStdinContents - = applyA ( getAttrValue a_strict_input - >>> - arr isTrueValue + = applyA ( getSysVar theStrictInput >>> arrIO FILE.getStdinCont >>> - ( arr (uncurry addError) -- io error occured + ( arr (uncurry addInputError) -- io error occured ||| arr addTxtContent -- content read ) ) -addError :: [(String, String)] -> String -> IOStateArrow s XmlTree XmlTree -addError al e +addInputError :: Attributes -> String -> IOStateArrow s XmlTree XmlTree +addInputError al e = issueFatal e >>> seqA (map (uncurry addAttr) al) @@ -150,7 +145,7 @@ addMimeType = addMime $< ( getAttrValue transferURI >>> - ( uriToMime $< getSysParam xio_mimeTypes ) + ( uriToMime $< getMimeTypeTable ) ) where addMime mt @@ -168,41 +163,7 @@ getHttpContents :: IOStateArrow s XmlTree XmlTree getHttpContents - = getCont $<< ( getAttrValue transferURI - &&& - ( ( getAttrlAsAssoc -- get all attributes of root node - &&& - getAllParamsString -- get all system params - ) - >>^ uncurry addEntries -- merge them, attributes overwrite system params - ) - ) - where - getAttrlAsAssoc -- get the attributes as assoc list - = listA ( getAttrl - >>> ( getName - &&& - xshow getChildren - ) - ) - - getCont uri options - = applyA ( ( traceMsg 2 ( "get HTTP via libcurl, uri=" ++ show uri ++ " options=" ++ show options ) - >>> - arrIO0 ( LibCURL.getCont options uri ) - ) - >>> - ( arr (uncurry addError) - ||| - arr addContent - ) - ) - - addContent :: (AssocList String String, String) -> IOStateArrow s XmlTree XmlTree - addContent (al, c) - = replaceChildren (txt c) - >>> - seqA (map (uncurry addAttr) al) + = withoutUserState $ applyA $ getSysVar theHttpHandler getURIContents :: IOStateArrow s XmlTree XmlTree getURIContents @@ -349,7 +310,7 @@ arr guessEncoding , getAttrValue transferEncoding -- 2. guess: take the transfer encoding , getAttrValue a_encoding -- 3. guess: take encoding parameter in root node - , getParamString a_encoding -- 4. guess: take encoding parameter in global state + , getSysVar theInputEncoding -- 4. guess: take encoding parameter in global state , constA utf8 -- default : utf8 ] >. (head . filter (not . null)) -- make the filter deterministic: take 1. entry from list of guesses @@ -358,7 +319,7 @@ getTextEncoding = catA [ getAttrValue transferEncoding -- 1. guess: take the transfer encoding , getAttrValue a_encoding -- 2. guess: take encoding parameter in root node - , getParamString a_encoding -- 3. guess: take encoding parameter in global state + , getSysVar theInputEncoding -- 3. guess: take encoding parameter in global state , constA isoLatin1 -- default : no encoding ] >. (head . filter (not . null)) -- make the filter deterministic: take 1. entry from list of guesses @@ -379,7 +340,7 @@ found df = traceMsg 2 ("decodeDocument: encoding is " ++ show enc) >>> - ( decodeText df $< getAttrValue a_ignore_encoding_errors ) + ( decodeText df $< getSysVar theEncodingErrors ) >>> addAttr transferEncoding enc @@ -388,7 +349,7 @@ >>> setDocumentStatusFromSystemState "decoding document" - decodeText df ignoreErrs + decodeText df withEncErrors = processChildren ( getText -- get the document content >>> arr df -- decode the text, result is (string, [errMsg]) @@ -396,9 +357,8 @@ ^>> mkText ) <+> - ( if isTrueValue ignoreErrs - then none -- encoding errors are ignored - else + ( if withEncErrors + then ( arrL snd -- take the error messages >>> arr ((enc ++) . (" encoding error" ++)) -- prefix with enc error @@ -407,6 +367,7 @@ >>> none -- neccessary for type match with <+> ) + else none ) ) ) diff --git a/src/Text/XML/HXT/Arrow/DocumentOutput.hs b/src/Text/XML/HXT/Arrow/DocumentOutput.hs --- a/src/Text/XML/HXT/Arrow/DocumentOutput.hs +++ b/src/Text/XML/HXT/Arrow/DocumentOutput.hs @@ -31,12 +31,11 @@ import Control.Arrow.ArrowIO import Control.Arrow.ListArrow -import Text.XML.HXT.DOM.Unicode ( getOutputEncodingFct ) +import Data.String.Unicode ( getOutputEncodingFct ) + import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow - import Text.XML.HXT.Arrow.Edit ( addHeadlineToXmlDoc , addXmlPi , addXmlPiEncoding @@ -44,6 +43,8 @@ , numberLinesInXmlDoc , treeRepOfXmlDoc ) +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs import System.IO ( Handle , IOMode(..) @@ -54,7 +55,6 @@ , hClose , stdout ) - import System.IO.Error ( try ) -- ------------------------------------------------------------ @@ -63,45 +63,47 @@ putXmlDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree putXmlDocument textMode dst - = perform ( xshow getChildren + = perform putDoc + where + putDoc + = xshow getChildren + >>> + arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s))) + >>> + ( ( traceMsg 1 ("io error, document not written to " ++ outFile) >>> - arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s))) + arr show >>> mkError c_fatal >>> - ( ( traceMsg 1 ("io error, document not written to " ++ outFile) - >>> - arr show >>> mkError c_fatal - >>> - filterErrorMsg - ) - ||| - ( traceMsg 2 ("document written to " ++ outFile) - >>> - none - ) - ) + filterErrorMsg ) - where - isStdout = null dst || dst == "-" + ||| + ( traceMsg 2 ("document written to " ++ outFile) + >>> + none + ) + ) + where + isStdout = null dst || dst == "-" - outFile = if isStdout - then "stdout" - else show dst + outFile = if isStdout + then "stdout" + else show dst - hPutDocument :: (Handle -> IO ()) -> IO () - hPutDocument action - | isStdout - = do - hSetBinaryMode stdout (not textMode) - action stdout - hSetBinaryMode stdout False - | otherwise - = do - handle <- ( if textMode - then openFile - else openBinaryFile - ) dst WriteMode - action handle - hClose handle + hPutDocument :: (Handle -> IO ()) -> IO () + hPutDocument action + | isStdout + = do + hSetBinaryMode stdout (not textMode) + action stdout + hSetBinaryMode stdout False + | otherwise + = do + handle <- ( if textMode + then openFile + else openBinaryFile + ) dst WriteMode + action handle + hClose handle -- | -- write the tree representation of a document to a file @@ -135,9 +137,9 @@ getEncodingParam :: IOStateArrow s XmlTree String getEncodingParam - = catA [ getParamString a_output_encoding -- 4. guess: take output encoding parameter from global state - , getParamString a_encoding -- 5. guess: take encoding parameter from global state - , constA utf8 -- default : utf8 + = catA [ getSysVar theOutputEncoding -- 4. guess: take output encoding parameter from global state + , getSysVar theInputEncoding -- 5. guess: take encoding parameter from global state + , constA utf8 -- default : utf8 ] >. (head . filter (not . null)) diff --git a/src/Text/XML/HXT/Arrow/Edit.hs b/src/Text/XML/HXT/Arrow/Edit.hs --- a/src/Text/XML/HXT/Arrow/Edit.hs +++ b/src/Text/XML/HXT/Arrow/Edit.hs @@ -66,10 +66,11 @@ import Control.Arrow.ArrowTree import Control.Arrow.ListArrow +import Data.Char.Properties.XMLCharProps ( isXmlSpaceChar ) + import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.DOM.Interface import qualified Text.XML.HXT.DOM.XmlNode as XN -import Text.XML.HXT.DOM.Unicode ( isXmlSpaceChar ) import Text.XML.HXT.DOM.FormatXmlTree ( formatXmlTree ) import Text.XML.HXT.Parser.HtmlParsec ( emptyHtmlTags ) import Text.XML.HXT.Parser.XmlEntities ( xmlEntities ) @@ -110,7 +111,7 @@ canonicalize1Node = (deep isPi `when` isDTD) -- remove DTD parts, except PIs >>> - (none `when` toBeRemoved) -- remove unintersting nodes + (none `when` toBeRemoved) -- remove uninteresting nodes >>> ( processAttrl ( processChildren transfCharRef >>> diff --git a/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs b/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs --- a/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs +++ b/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: GeneralEntitySubstitution.hs,v 1.13 2006/05/01 18:56:24 hxml Exp $ general entity substitution @@ -26,8 +25,9 @@ import Control.Arrow.ArrowTree import Text.XML.HXT.DOM.Interface + import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.Arrow.ParserInterface ( parseXmlAttrValue diff --git a/src/Text/XML/HXT/Arrow/Namespace.hs b/src/Text/XML/HXT/Arrow/Namespace.hs --- a/src/Text/XML/HXT/Arrow/Namespace.hs +++ b/src/Text/XML/HXT/Arrow/Namespace.hs @@ -109,14 +109,14 @@ -- ------------------------------------------------------------ --- | generate unique namespaces and add all namespace declarations to the root element +-- | generate unique namespaces and add all namespace declarations to all top nodes containing a namespace declaration +-- Usually the top node containing namespace declarations is the root node, but this isn't mandatory. -- -- Calls 'cleanupNamespaces' with 'collectNamespaceDecl' -uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree -uniqueNamespaces - = fromLA $ - cleanupNamespaces collectNamespaceDecl +uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree +uniqueNamespaces = fromLA $ + cleanupNamespaces' collectNamespaceDecl -- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names -- @@ -124,10 +124,22 @@ -- Calls 'cleanupNamespaces' with @ collectNamespaceDecl \<+> collectPrefixUriPairs @ uniqueNamespacesFromDeclAndQNames :: ArrowXml a => a XmlTree XmlTree -uniqueNamespacesFromDeclAndQNames - = fromLA $ - cleanupNamespaces (collectNamespaceDecl <+> collectPrefixUriPairs) +uniqueNamespacesFromDeclAndQNames = fromLA $ + cleanupNamespaces' ( collectNamespaceDecl + <+> + collectPrefixUriPairs + ) +cleanupNamespaces' :: LA XmlTree (String, String) -> LA XmlTree XmlTree +cleanupNamespaces' collectNamespaces = processTopDownUntil + ( hasNamespaceDecl `guards` cleanupNamespaces collectNamespaces ) + where + hasNamespaceDecl = isElem + >>> + getAttrl + >>> + isNamespaceDeclAttr + -- | does the real work for namespace cleanup. -- -- The parameter is used for collecting namespace uris and prefixes from the input tree @@ -148,7 +160,7 @@ changeQName renamePrefix -- update namespace prefix of element names ) >>> - attachEnv env1 -- all all namespaces as attributes to the root node attribute list + attachEnv env1 -- add all namespaces as attributes to the root node attribute list where renamePrefix :: QName -> QName renamePrefix n diff --git a/src/Text/XML/HXT/Arrow/ParserInterface.hs b/src/Text/XML/HXT/Arrow/ParserInterface.hs --- a/src/Text/XML/HXT/Arrow/ParserInterface.hs +++ b/src/Text/XML/HXT/Arrow/ParserInterface.hs @@ -1,8 +1,19 @@ --- | --- interface to the HXT XML and DTD parsers --- --- version: $Id: ParserInterface.hs,v 1.1 2006/05/01 18:56:24 hxml Exp $ +-- ------------------------------------------------------------ +{- | + Module : Text.XML.HXT.Arrow.ParserInterface + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : stable + Portability: portable + + interface to the HXT XML and DTD parsers +-} + +-- ------------------------------------------------------------ + module Text.XML.HXT.Arrow.ParserInterface ( module Text.XML.HXT.Arrow.ParserInterface ) where @@ -19,11 +30,9 @@ import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow -import qualified Text.XML.HXT.Parser.TagSoup as TS import qualified Text.XML.HXT.Parser.HtmlParsec as HP import qualified Text.XML.HXT.Parser.XmlParsec as XP import qualified Text.XML.HXT.Parser.XmlDTDParser as DP -import qualified Text.XML.HXT.DTDValidation.Validation as VA -- ------------------------------------------------------------ @@ -68,25 +77,6 @@ parseHtmlContent :: ArrowList a => a String XmlTree parseHtmlContent = arrL HP.parseHtmlContent - -parseHtmlTagSoup :: ArrowList a => Bool -> Bool -> Bool -> Bool -> Bool -> a (String, String) XmlTree -parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml - = arr2L (TS.parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml) - --- ------------------------------------------------------------ - -validateDoc :: ArrowList a => a XmlTree XmlTree -validateDoc = fromLA ( VA.validate - `when` - VA.getDTDSubset -- validate only when DTD decl is present - ) - -transformDoc :: ArrowList a => a XmlTree XmlTree -transformDoc = fromLA VA.transform - --- old stuff --- validateDoc = arrL VA.validate --- transformDoc = arrL VA.transform -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/Pickle.hs b/src/Text/XML/HXT/Arrow/Pickle.hs --- a/src/Text/XML/HXT/Arrow/Pickle.hs +++ b/src/Text/XML/HXT/Arrow/Pickle.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id$ Pickler functions for converting between user defined data types and XmlTree data. Usefull for persistent storage and retreival @@ -50,6 +49,7 @@ -- from Text.XML.HXT.Arrow.Pickle.Xml , pickleDoc , unpickleDoc + , showPickled , PU(..) , XmlPickler @@ -57,9 +57,29 @@ , xp4Tuple , xp5Tuple , xp6Tuple + , xp7Tuple + , xp8Tuple + , xp9Tuple + , xp10Tuple + , xp11Tuple + , xp12Tuple + , xp13Tuple + , xp14Tuple + , xp15Tuple + , xp16Tuple + , xp17Tuple + , xp18Tuple + , xp19Tuple + , xp20Tuple + , xp21Tuple + , xp22Tuple + , xp23Tuple + , xp24Tuple + , xpAddFixedAttr , xpAlt , xpAttr + , xpTextAttr , xpAttrFixed , xpAttrImplied , xpChoice @@ -102,10 +122,12 @@ import Control.Arrow.ListArrows import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow + import Text.XML.HXT.Arrow.ReadDocument import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs import Text.XML.HXT.Arrow.Pickle.Xml import Text.XML.HXT.Arrow.Pickle.Schema @@ -123,21 +145,25 @@ -- An option evaluated by this arrow is 'a_addDTD'. -- If 'a_addDTD' is set ('v_1'), the pickler DTD is added as an inline DTD into the document. -xpickleDocument :: PU a -> Attributes -> String -> IOStateArrow s a XmlTree -xpickleDocument xp al dest - = xpickleVal xp +xpickleDocument :: PU a -> SysConfigList -> String -> IOStateArrow s a XmlTree +xpickleDocument xp config dest + = localSysEnv + $ + configSysVars config >>> + xpickleVal xp + >>> traceMsg 1 "xpickleVal applied" >>> - ( if lookup1 a_addDTD al == v_1 - then replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren) - <+> - getChildren - ) - else this - ) + ifA ( getSysAttr a_addDTD >>> isA (== v_1) ) + ( replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren) + <+> + getChildren + ) + ) + this >>> - writeDocument al dest + writeDocument [] dest -- | Option for generating and adding DTD when document is pickled @@ -154,9 +180,9 @@ -- when applied with the appropriate options. When during pickling indentation is switched on, -- the whitespace must be removed during unpickling. -xunpickleDocument :: PU a -> Attributes -> String -> IOStateArrow s b a -xunpickleDocument xp al src - = readDocument al src +xunpickleDocument :: PU a -> SysConfigList -> String -> IOStateArrow s b a +xunpickleDocument xp conf src + = readDocument conf src >>> traceMsg 1 ("xunpickleVal for " ++ show src ++ " started") >>> @@ -166,11 +192,11 @@ -- | Write out the DTD generated out of a pickler. Calls 'xpicklerDTD' -xpickleWriteDTD :: PU b -> Attributes -> String -> IOStateArrow s b XmlTree -xpickleWriteDTD xp al dest +xpickleWriteDTD :: PU b -> SysConfigList -> String -> IOStateArrow s b XmlTree +xpickleWriteDTD xp config dest = xpickleDTD xp >>> - writeDocument al dest + writeDocument config dest -- | The arrow for generating the DTD out of a pickler -- @@ -204,7 +230,7 @@ >>> writeDocumentToString [] >>> - readFromString [(a_validate, v_1)] + readFromString [withValidate True] >>> ( xunpickleVal xp `orElse` @@ -240,5 +266,3 @@ thePicklerDTD = dtdDescrToXml . dtdDescr . theSchema -- ------------------------------------------------------------ - - diff --git a/src/Text/XML/HXT/Arrow/Pickle/DTD.hs b/src/Text/XML/HXT/Arrow/Pickle/DTD.hs --- a/src/Text/XML/HXT/Arrow/Pickle/DTD.hs +++ b/src/Text/XML/HXT/Arrow/Pickle/DTD.hs @@ -26,7 +26,7 @@ import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.Pickle.Schema -import Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C +import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/Pickle/Schema.hs b/src/Text/XML/HXT/Arrow/Pickle/Schema.hs --- a/src/Text/XML/HXT/Arrow/Pickle/Schema.hs +++ b/src/Text/XML/HXT/Arrow/Pickle/Schema.hs @@ -23,7 +23,7 @@ where import Text.XML.HXT.DOM.TypeDefs -import Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C +import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames import Data.List ( sort ) diff --git a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs --- a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs +++ b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + -- ------------------------------------------------------------ {- | @@ -38,6 +40,8 @@ module Text.XML.HXT.Arrow.Pickle.Xml where +import Control.Arrow.ListArrows + import Data.Maybe import Data.Map (Map) import qualified Data.Map as M @@ -45,11 +49,12 @@ import Text.XML.HXT.DOM.Interface import qualified Text.XML.HXT.DOM.XmlNode as XN -import Control.Arrow.ListArrows -import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.Edit (xshowEscapeXml) import Text.XML.HXT.Arrow.Pickle.Schema import Text.XML.HXT.Arrow.ReadDocument (xread) -import Text.XML.HXT.Arrow.Edit (xshowEscapeXml) +import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString) +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState -- ------------------------------------------------------------ @@ -119,6 +124,13 @@ -- ------------------------------------------------------------ +-- | Pickles a value, then writes the document to a string. + +showPickled :: (XmlPickler a) => SysConfigList -> a -> String +showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) + +-- ------------------------------------------------------------ + -- | The zero pickler -- -- Encodes nothing, fails always during unpickling @@ -220,6 +232,8 @@ xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa } +-- ------------------------------------------------------------ + -- | pickle a pair of values sequentially -- -- Used for pairs or together with wrap for pickling @@ -268,6 +282,191 @@ toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f ) fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f))))) +-- ------------------------------------------------------------ + +-- | Like 'xpPair' and 'xpTriple' but for 7-tuples +-- +-- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple. + +xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU (a, b, c, d, e, f, g) +xp7Tuple a b c d e f g + = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g) + , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)) + ) + (xpPair a (xp6Tuple b c d e f g)) + +xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h) +xp8Tuple a b c d e f g h + = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h) + , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h)) + ) + (xpPair (xpPair a b) (xp6Tuple c d e f g h)) + +xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i) +xp9Tuple a b c d e f g h i + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i) + , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i)) + ) + (xpPair (xpTriple a b c) (xp6Tuple d e f g h i)) + +xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU (a, b, c, d, e, f, g, h, i, j) +xp10Tuple a b c d e f g h i j + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j) + , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j)) + ) + (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j)) + +xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU (a, b, c, d, e, f, g, h, i, j, k) +xp11Tuple a b c d e f g h i j k + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k) + , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k)) + ) + (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k)) + +xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l) +xp12Tuple a b c d e f g h i j k l + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l) + , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l)) + ) + (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l)) + +xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m) +xp13Tuple a b c d e f g h i j k l m + = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) + ) + (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m)) + +xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +xp14Tuple a b c d e f g h i j k l m n + = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) + ) + (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n)) + +xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +xp15Tuple a b c d e f g h i j k l m n o + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) + ) + (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o)) + +xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) +xp16Tuple a b c d e f g h i j k l m n o p + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) + ) + (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p)) + +xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) +xp17Tuple a b c d e f g h i j k l m n o p q + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) + ) + (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q)) + +xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) +xp18Tuple a b c d e f g h i j k l m n o p q r + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) + ) + (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r)) + +xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) +xp19Tuple a b c d e f g h i j k l m n o p q r s + = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) + ) + (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s)) + +xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) +xp20Tuple a b c d e f g h i j k l m n o p q r s t + = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) + ) + (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t)) + +xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) +xp21Tuple a b c d e f g h i j k l m n o p q r s t u + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) + ) + (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u)) + +xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) +xp22Tuple a b c d e f g h i j k l m n o p q r s t u v + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) + ) + (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v)) + +xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) +xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) + ) + (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w)) + +-- | Hopefully no one needs a xp25Tuple + +xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) +xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) + ) + (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x)) + +-- ------------------------------------------------------------ + + -- | Pickle a string into an XML text node -- -- One of the most often used primitive picklers. Attention: @@ -623,6 +822,10 @@ xpAttr :: String -> PU a -> PU a xpAttr = xpAttrQN . mkName +-- | A text attribute. +xpTextAttr :: String -> PU String +xpTextAttr = flip xpAttr xpText + -- | Add an optional attribute for an optional value (Maybe a). xpAttrImplied :: String -> PU a -> PU (Maybe a) @@ -692,3 +895,42 @@ xpickle = xpOption xpickle -- ------------------------------------------------------------ + +-- ------------------------------------------------------------ +{- +-- | Extra library functions for HXT. +module Text.XML.HXT.Extras( + showPickled, + textAttr, + xp7Tuple, + xp8Tuple, + xp9Tuple, + xp10Tuple, + xp11Tuple, + xp12Tuple, + xp13Tuple, + xp14Tuple, + xp15Tuple, + xp16Tuple, + xp17Tuple, + xp18Tuple, + xp19Tuple, + xp20Tuple, + xp21Tuple, + xp22Tuple, + xp23Tuple, + xp24Tuple + ) where + +import Text.XML.HXT.Arrow + +-- | Pickles a value then writes the document to a string. +showPickled :: (XmlPickler a) => Attributes -> a -> String +showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) + +-- | A text attribute. +textAttr :: String -> PU String +textAttr = flip xpAttr xpText +-} +-- ------------------------------------------------------------ + diff --git a/src/Text/XML/HXT/Arrow/ProcessDocument.hs b/src/Text/XML/HXT/Arrow/ProcessDocument.hs --- a/src/Text/XML/HXT/Arrow/ProcessDocument.hs +++ b/src/Text/XML/HXT/Arrow/ProcessDocument.hs @@ -8,7 +8,6 @@ Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable - Version : $Id: ProcessDocument.hs,v 1.3 2006/08/30 16:20:52 hxml Exp $ Compound arrows for reading, parsing, validating and writing XML documents @@ -22,6 +21,7 @@ , parseHtmlDocument , validateDocument , propagateAndValidateNamespaces + , andValidateNamespaces , getDocumentContents ) where @@ -30,40 +30,39 @@ import Control.Arrow.ArrowList import Control.Arrow.ArrowIf import Control.Arrow.ArrowTree +import Control.Arrow.ListArrow ( fromLA ) import Text.XML.HXT.DOM.Interface + import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs -import Text.XML.HXT.Arrow.ParserInterface - ( parseXmlDoc - , parseHtmlDoc - , parseHtmlTagSoup - , substHtmlEntityRefs - , validateDoc - , transformDoc - ) +import Text.XML.HXT.Arrow.ParserInterface ( parseXmlDoc + , parseHtmlDoc + , substHtmlEntityRefs + ) -import Text.XML.HXT.Arrow.Edit - ( transfAllCharRef - ) +import Text.XML.HXT.Arrow.Edit ( transfAllCharRef + ) import Text.XML.HXT.Arrow.GeneralEntitySubstitution - ( processGeneralEntities - ) + ( processGeneralEntities + ) -import Text.XML.HXT.Arrow.DTDProcessing - ( processDTD - ) +import Text.XML.HXT.Arrow.DTDProcessing ( processDTD + ) -import Text.XML.HXT.Arrow.DocumentInput - ( getXmlContents - ) +import Text.XML.HXT.Arrow.DocumentInput ( getXmlContents + ) -import Text.XML.HXT.Arrow.Namespace - ( propagateNamespaces - , validateNamespaces - ) +import Text.XML.HXT.Arrow.Namespace ( propagateNamespaces + , validateNamespaces + ) +import Text.XML.HXT.DTDValidation.Validation ( validate + , getDTDSubset + , transform + ) -- ------------------------------------------------------------ @@ -87,7 +86,7 @@ -} parseXmlDocument :: Bool -> IOStateArrow s XmlTree XmlTree -parseXmlDocument validate +parseXmlDocument validate' = ( replaceChildren ( ( getAttrValue a_source &&& xshow getChildren @@ -106,7 +105,7 @@ >>> transfAllCharRef >>> - ( if validate + ( if validate' then validateDocument else this ) @@ -129,19 +128,14 @@ -} -parseHtmlDocument :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree -parseHtmlDocument withTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml +parseHtmlDocument :: IOStateArrow s XmlTree XmlTree +parseHtmlDocument = ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) ) >>> - replaceChildren ( ( getAttrValue a_source -- get source name - &&& - xshow getChildren - ) -- get string to be parsed - >>> - parseHtml - ) + ( parseHtml $< getSysVar theTagSoup ) >>> - removeWarnings + ( removeWarnings $< getSysVar (theWarnings .&&&. theTagSoup ) + ) >>> setDocumentStatusFromSystemState "parse HTML document" >>> @@ -156,20 +150,24 @@ ) `when` documentStatusOk where - parseHtml - | withTagSoup = traceMsg 1 ("parse document with tagsoup " ++ - ( if asHtml then "HT" else "X" ) ++ "ML parser" - ) - >>> - parseHtmlTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml + parseHtml withTagSoup' + | withTagSoup' = withoutUserState $< getSysVar theTagSoupParser -- withoutUserState parseHtmlTagSoup | otherwise = traceMsg 1 ("parse document with parsec HTML parser") >>> - parseHtmlDoc -- run parser + replaceChildren + ( ( getAttrValue a_source -- get source name + &&& + xshow getChildren + ) -- get string to be parsed + >>> + parseHtmlDoc -- run parser + ) >>> substHtmlEntityRefs -- substitute entity refs - removeWarnings - | withTagSoup + + removeWarnings (warnings, withTagSoup') + | withTagSoup' && not warnings = this | otherwise = processTopDownWithAttrl @@ -209,9 +207,11 @@ >>> setDocumentStatusFromSystemState "document validation" >>> + traceMsg 1 "document validated, transforming doc with respect to DTD" + >>> transformDoc >>> - traceMsg 1 "document validated" + traceMsg 1 "document transformed" >>> traceSource >>> @@ -245,7 +245,14 @@ >>> traceDoc "propagating namespaces done" >>> - traceMsg 1 "validating namespaces" + andValidateNamespaces + ) + `when` + documentStatusOk + +andValidateNamespaces :: IOStateArrow s XmlTree XmlTree +andValidateNamespaces + = ( traceMsg 1 "validating namespaces" >>> ( setDocumentStatusFromSystemState "namespace propagation" `when` @@ -269,16 +276,25 @@ For supported protocols see 'Text.XML.HXT.Arrow.DocumentInput.getXmlContents' -} -getDocumentContents :: Attributes -> String -> IOStateArrow s b XmlTree -getDocumentContents options src +getDocumentContents :: String -> IOStateArrow s b XmlTree +getDocumentContents src = root [] [] >>> addAttr a_source src >>> - seqA (map (uncurry addAttr) options) -- add all options to doc root - >>> -- e.g. getXmlContents needs some of these traceMsg 1 ("readDocument: start processing document " ++ show src) >>> getXmlContents + +-- ------------------------------------------------------------ + +validateDoc :: ArrowList a => a XmlTree XmlTree +validateDoc = fromLA ( validate + `when` + getDTDSubset -- validate only when DTD decl is present + ) + +transformDoc :: ArrowList a => a XmlTree XmlTree +transformDoc = fromLA transform -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/ReadDocument.hs b/src/Text/XML/HXT/Arrow/ReadDocument.hs --- a/src/Text/XML/HXT/Arrow/ReadDocument.hs +++ b/src/Text/XML/HXT/Arrow/ReadDocument.hs @@ -6,11 +6,10 @@ License : MIT Maintainer : Uwe Schmidt (uwe@fh-wedel.de) - Stability : experimental + Stability : stable Portability: portable - Version : $Id: ReadDocument.hs,v 1.10 2006/11/24 07:41:37 hxml Exp $ -Compound arrows for reading an XML\/HTML document or an XML\/HTML string + Compound arrows for reading an XML\/HTML document or an XML\/HTML string -} @@ -28,179 +27,167 @@ import Control.Arrow.ListArrows -import Data.Char ( isDigit ) import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.Edit ( canonicalizeAllNodes , canonicalizeForXPath , canonicalizeContents , rememberDTDAttrl , removeDocWhiteSpace ) - import Text.XML.HXT.Arrow.ParserInterface - import Text.XML.HXT.Arrow.ProcessDocument ( getDocumentContents , parseXmlDocument , parseHtmlDocument , propagateAndValidateNamespaces + , andValidateNamespaces ) - -import Text.XML.HXT.RelaxNG.Validator ( validateDocumentWithRelaxSchema ) +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs -- ------------------------------------------------------------ - +-- {- | the main document input filter -this filter can be configured by an option list, a value of type 'Text.XML.HXT.DOM.TypeDefs.Attributes' - -available options: - -* 'a_parse_html': use HTML parser, else use XML parser (default) - -- 'a_tagsoup' : use light weight and lazy parser based on tagsoup lib - -- 'a_parse_by_mimetype' : select the parser by the mime type of the document - (pulled out of the HTTP header). When the mime type is set to \"text\/html\" - the HTML parser (parsec or tagsoup) is taken, when it\'s set to - \"text\/xml\" or \"text\/xhtml\" the XML parser (parsec or tagsoup) is taken. - If the mime type is something else no further processing is performed, - the contents is given back to the application in form of a single text node. - If the default document encoding ('a_encoding') is set to isoLatin1, this even enables processing - of arbitray binary data. - -- 'a_validate' : validate document againsd DTD (default), else skip validation - -- 'a_relax_schema' : validate document with Relax NG, the options value is the schema URI - this implies using XML parser, no validation against DTD, and canonicalisation - -- 'a_check_namespaces' : check namespaces, else skip namespace processing (default) - -- 'a_canonicalize' : canonicalize document (default), else skip canonicalization - -- 'a_preserve_comment' : preserve comments during canonicalization, else remove comments (default) - -- 'a_remove_whitespace' : remove all whitespace, used for document indentation, else skip this step (default) - -- 'a_indent' : indent document by inserting whitespace, else skip this step (default) - -- 'a_issue_warnings' : issue warnings, when parsing HTML (default), else ignore HTML parser warnings - -- 'a_issue_errors' : issue all error messages on stderr (default), or ignore all error messages - -- 'a_ignore_encoding_errors': ignore all encoding errors, default is issue all encoding errors - -- 'a_ignore_none_xml_contents': ignore document contents of none XML\/HTML documents. - This option can be useful for implementing crawler like applications, e.g. an URL checker. - In those cases net traffic can be reduced. - -- 'a_trace' : trace level: values: 0 - 4 - -- 'a_proxy' : proxy for http access, e.g. www-cache:3128 - -- 'a_redirect' : automatically follow redirected URIs, default is yes +this filter can be configured by a list of configuration options, a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' -- 'a_use_curl' : obsolete and ignored, HTTP acccess is always done with curl bindings for libcurl +for all available options see module 'Text.XML.HXT.XmlState.SystemConfig' -- 'a_strict_input' : file input is done strictly using the 'Data.ByteString' input functions. This ensures correct closing of files, especially when working with - the tagsoup parser and not processing the whole input data. Default is off. The @ByteString@ input usually is not faster than the buildin @hGetContents@ - for strings. +- @withValidate yes\/no@ : + switch on\/off DTD validation. Only for XML parsed documents, not for HTML parsing. -- 'a_options_curl' : deprecated but for compatibility reasons still supported. - More options passed to the curl binding. - Instead of using this option to set a whole bunch of options at once for curl - it is recomended to use the @curl-.*@ options syntax described below. +- @withParseHTML yes\/no@ : + switch on HTML parsing. -- 'a_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', 'iso8859_2', ... , 'iso8859_16', ...). - Only XML, HTML and text documents are decoded, - default decoding for XML\/HTML is utf8, for text iso latin1 (no decoding). - The whole content is returned in a single text node. +- @withParseByMimeType yes\/no@ : + select XML\/HTML parser by document mime type. + text\/xml and text\/xhtml are parsed as XML, text\/html as HTML. -- 'a_mime_types' : set the mime type table for file input with given file. The format of this config file must be in the syntax of a debian linux \"mime.types\" config file +- @withCheckNamespaces yes\/no@ : + Switch on\/off namespace propagation and checking -- 'a_if_modified_since' : read document conditionally, only if the document is newer than the given date and time argument, the contents is delivered, - else just the root node with the meta data is returned. The date and time must be given in "System.Locale.rfc822DateFormat". +- @withInputEncoding @ : + Set default encoding. -- curl options : the HTTP interface with libcurl can be configured with a lot of options. To support these options in an easy way, there is a naming convetion: - Every option, which has the prefix @curl@ and the rest of the name forms an option as described in the curl man page, is passed to the curl binding lib. - See 'Text.XML.HXT.IO.GetHTTPLibCurl.getCont' for examples. Currently most of the options concerning HTTP requests are implemented. +- @withTagSoup@ : + use light weight and lazy parser based on tagsoup lib. + This is only available when package hxt-tagsoup is installed and + 'Text.XML.HXT.TagSoup' is imported -All attributes not evaluated by readDocument are stored in the created document root node for easy access of the various -options in e.g. the input\/output modules +- @withRelaxNG @ : + validate document with Relax NG, the parameter is for the schema URI. + This implies using XML parser, no validation against DTD, and canonicalisation. -If the document name is the empty string or an uri of the form \"stdin:\", the document is read from standard input. +- @withCurl [...]@ : + Use the libCurl binding for HTTP access. + This is only available when package hxt-curl is installed and + 'Text.XML.HXT.Curl' is imported + +- @withHTTP [...]@ : + Use the Haskell HTTP package for HTTP access. + This is only available when package hxt-http is installed and + 'Text.XML.HXT.HTTP' is imported examples: -> readDocument [ ] "test.xml" +> readDocument [] "test.xml" reads and validates a document \"test.xml\", no namespace propagation, only canonicalization is performed -> readDocument [ (a_validate, "0") -> , (a_encoding, isoLatin1) -> , (a_parse_by_mimetype, "1") -> ] "http://localhost/test.php" +> ... +> import Text.XML.HXT.Curl +> ... +> +> readDocument [ withValidate no +> , withInputEncoding isoLatin1 +> , withParseByMimeType yes +> , withCurl [] +> ] \"http:\/\/localhost\/test.php\" reads document \"test.php\", parses it as HTML or XML depending on the mimetype given from the server, but without validation, default encoding 'isoLatin1'. - +HTTP access is done via libCurl. -> readDocument [ (a_parse_html, "1") -> , (a_encoding, isoLatin1) +> readDocument [ withParseHTML yes +> , withInputEncoding isoLatin1 > ] "" reads a HTML document from standard input, no validation is done when parsing HTML, default encoding is 'isoLatin1', -parsing is done with tagsoup parser, but input is read strictly -> readDocument [ (a_encoding, isoLatin1) -> , (a_mime_type, "/etc/mime.types") -> , (a_tagsoup, "1") -> , (a_strict_input, "1") +> readDocument [ withInputEncoding isoLatin1 +> , withValidate no +> , withMimeTypeFile "/etc/mime.types" +> , withStrictInput yes > ] "test.svg" -reads an SVG document from standard input, sets the mime type by looking in the system mimetype config file, default encoding is 'isoLatin1', -parsing is done with the lightweight tagsoup parser, which implies no validation. +reads an SVG document from \"test.svg\", sets the mime type by looking in the system mimetype config file, +default encoding is 'isoLatin1', -> readDocument [ (a_parse_html, "1") -> , (a_proxy, "www-cache:3128") -> , (a_curl, "1") -> , (a_issue_warnings, "0") +> ... +> import Text.XML.HXT.Curl +> import Text.XML.HXT.TagSoup +> ... +> +> readDocument [ withParseHTML yes +> , withTagSoup +> , withProxy "www-cache:3128" +> , withCurl [] +> , withWarnings no > ] "http://www.haskell.org/" -reads Haskell homepage with HTML parser ignoring any warnings, with http access via external program curl and proxy \"www-cache\" at port 3128 +reads Haskell homepage with HTML parser, ignoring any warnings +(at the time of writing, there were some HTML errors), +with http access via libCurl interface +and proxy \"www-cache\" at port 3128, +parsing is done with tagsoup HTML parser. +This requires packages \"hxt-curl\" and \"hxt-tagsoup\" to be installed -> readDocument [ (a_validate, "1") -> , (a_check_namespace, "1") -> , (a_remove_whitespace, "1") -> , (a_trace, "2") +> readDocument [ withValidate yes +> , withCheckNamespaces yes +> , withRemoveWS yes +> , withTrace 2 +> , withHTTP [] > ] "http://www.w3c.org/" -read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2 +read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2. +HTTP access is done with Haskell HTTP package for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument' and 'runX', the main starting point for running an XML arrow. -} -readDocument :: Attributes -> String -> IOStateArrow s b XmlTree -readDocument userOptions src - = case getTraceLev of - Nothing -> readDocument' userOptions src - Just l -> withTraceLevel l $ readDocument' userOptions src - where - getTraceLev = do - s <- lookup a_trace $ userOptions - if not (null s) && all isDigit s - then return (read s) - else fail "not a number" +readDocument :: SysConfigList -> String -> IOStateArrow s b XmlTree +readDocument config src + = localSysEnv + $ + readDocument' config src -readDocument' :: Attributes -> String -> IOStateArrow s b XmlTree -readDocument' userOptions src - = loadMineTypes (lookup1 a_mime_types userOptions) +readDocument' :: SysConfigList -> String -> IOStateArrow s b XmlTree +readDocument' config src + = configSysVars config >>> - getDocumentContents options src + readD $< getSysVar theWithCache + where + readD True = constA undefined -- just for generalizing the signature to: IOStateArrow s b XmlTree + >>> -- instead of IOStateArrow s XmlTree XmlTree + (withoutUserState $< (getSysVar theCacheRead >>^ ($ src))) + readD False = readDocument'' src + +readDocument'' :: String -> IOStateArrow s b XmlTree +readDocument'' src + = getDocumentContents src >>> - ( processDoc $< getMimeType ) + ( processDoc + $<< + ( getMimeType + &&& + getSysVar (theParseByMimeType .&&&. + theParseHTML .&&&. + theAcceptedMimeTypes .&&&. + theRelaxValidate + ) + ) + ) >>> traceMsg 1 ("readDocument: " ++ show src ++ " processed") >>> @@ -208,48 +195,40 @@ >>> traceTree where - options - = addEntries userOptions defaultOptions - - defaultOptions - = [ ( a_parse_html, v_0 ) - , ( a_tagsoup, v_0 ) - , ( a_strict_input, v_0 ) - , ( a_validate, v_1 ) - , ( a_issue_warnings, v_1 ) - , ( a_check_namespaces, v_0 ) - , ( a_canonicalize, v_1 ) - , ( a_preserve_comment, v_0 ) - , ( a_remove_whitespace, v_0 ) - , ( a_parse_by_mimetype, v_0 ) - , ( a_ignore_encoding_errors, v_0 ) - , ( a_ignore_none_xml_contents, v_0 ) - , ( a_accept_mimetypes, "" ) - ] - - loadMineTypes "" = this - loadMineTypes f = setMimeTypeTableFromFile f - getMimeType = getAttrValue transferMimeType >>^ stringToLower - processDoc mimeType + processDoc mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax))) = traceMsg 1 (unwords [ "readDocument:", show src , "(mime type:", show mimeType, ") will be processed"]) >>> - ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType + ( if isAcceptedMimeType acceptedMimeTypes mimeType then ( ifA (fromLA hasEmptyBody) ( replaceChildren none ) -- empty response, e.g. in if-modified-since request - ( parse + ( ( parse $< getSysVar (theValidate .&&&. + theIgnoreNoneXmlContents .&&&. + theTagSoup + ) + ) >>> ( if isXmlOrHtml - then ( checknamespaces + then ( ( checknamespaces $< getSysVar (theCheckNamespaces .&&&. + theTagSoup + ) + ) >>> rememberDTDAttrl >>> - canonicalize + ( canonicalize $< getSysVar (thePreserveComment .&&&. + theCanonicalize .&&&. + theTagSoup + ) + ) >>> - whitespace + ( whitespace $< getSysVar (theRemoveWS .&&&. + theTagSoup + ) + ) >>> relax ) @@ -272,7 +251,7 @@ ( getChildren >>> isWhiteSpace ) ) - isAcceptedMimeType :: String -> String -> Bool + isAcceptedMimeType :: [String] -> String -> Bool isAcceptedMimeType mts mt | null mts || @@ -280,9 +259,7 @@ | otherwise = foldr (matchMt mt') False $ mts' where mt' = parseMt mt - mts' = words - >>> - map parseMt + mts' = map parseMt $ mts parseMt = break (== '/') @@ -293,75 +270,73 @@ (mi == mis || mis == "*") ) || r - parse + parse (validate, (removeNoneXml, withTagSoup')) + | not isXmlOrHtml = if removeNoneXml + then replaceChildren none -- don't parse, if mime type is not XML nor HTML + else this -- but remove contents when option is set + | isHtml - || - withTagSoup = parseHtmlDocument -- parse as HTML or with tagsoup XML - withTagSoup - withNamespaces - issueW - (not (hasOption a_canonicalize) && preserveCmt) - removeWS - isHtml - | validateWithRelax = parseXmlDocument False -- for Relax NG use XML parser without validation - | isXml = parseXmlDocument validate -- parse as XML - | removeNoneXml = replaceChildren none -- don't parse, if mime type is not XML nor HTML - | otherwise = this -- but remove contents when option is set - checknamespaces - | (withNamespaces && not withTagSoup) + || + withTagSoup' = configSysVar (setS theLowerCaseNames isHtml) + >>> + parseHtmlDocument -- parse as HTML or with tagsoup XML + + | isXml = parseXmlDocument (not validateWithRelax && validate) -- parse as XML + | otherwise = this -- suppress warning + + checknamespaces (withNamespaces, withTagSoup') + | withNamespaces + && + withTagSoup' = andValidateNamespaces -- propagation is done in tagsoup + + | withNamespaces || - validateWithRelax = propagateAndValidateNamespaces + validateWithRelax = propagateAndValidateNamespaces -- RelaxNG requires correct namespaces + | otherwise = this - canonicalize - | withTagSoup = this -- tagsoup already removes redundant stuff + + canonicalize (preserveCmt, (canonicalize', withTagSoup')) + | withTagSoup' = this -- tagsoup already removes redundant stuff | validateWithRelax = canonicalizeAllNodes - | hasOption a_canonicalize + | canonicalize' && preserveCmt = canonicalizeForXPath - | hasOption a_canonicalize = canonicalizeAllNodes + | canonicalize' = canonicalizeAllNodes | otherwise = this + relax - | validateWithRelax = validateDocumentWithRelaxSchema options relaxSchema + | validateWithRelax = withoutUserState $< getSysVar theRelaxValidator | otherwise = this - whitespace + + whitespace (removeWS, withTagSoup') | removeWS && - not withTagSoup = removeDocWhiteSpace -- tagsoup already removes whitespace + not withTagSoup' = removeDocWhiteSpace -- tagsoup already removes whitespace | otherwise = this - validateWithRelax = hasEntry a_relax_schema options - relaxSchema = lookup1 a_relax_schema options - parseHtml = hasOption a_parse_html - isHtml = parseHtml -- force HTML - || - ( parseByMimeType && isHtmlMimeType mimeType ) - isXml = ( not parseByMimeType && not parseHtml ) - || - ( parseByMimeType - && - ( isXmlMimeType mimeType - || - null mimeType - ) -- mime type is XML or not known - ) + + isHtml = ( not parseByMimeType && parseHtml ) -- force HTML + || + ( parseByMimeType && isHtmlMimeType mimeType ) + + isXml = ( not parseByMimeType && not parseHtml ) + || + ( parseByMimeType + && + ( isXmlMimeType mimeType + || + null mimeType + ) -- mime type is XML or not known + ) + isXmlOrHtml = isHtml || isXml - parseByMimeType = hasOption a_parse_by_mimetype - validate = hasOption a_validate - withNamespaces = hasOption a_check_namespaces - withTagSoup = hasOption a_tagsoup - issueW = hasOption a_issue_warnings - removeWS = hasOption a_remove_whitespace - preserveCmt = hasOption a_preserve_comment - removeNoneXml = hasOption a_ignore_none_xml_contents - hasOption n = optionIsSet n options -- ------------------------------------------------------------ -- | -- the arrow version of 'readDocument', the arrow input is the source URI -readFromDocument :: Attributes -> IOStateArrow s String XmlTree -readFromDocument userOptions - = applyA ( arr $ readDocument userOptions ) +readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree +readFromDocument config = applyA ( arr $ readDocument config ) -- ------------------------------------------------------------ @@ -373,18 +348,19 @@ -- -- Default encoding: No encoding is done, the String argument is taken as Unicode string -readString :: Attributes -> String -> IOStateArrow s b XmlTree -readString userOptions content - = readDocument ( (a_encoding, unicodeString) : userOptions ) (stringProtocol ++ content) +readString :: SysConfigList -> String -> IOStateArrow s b XmlTree +readString config content + = readDocument (withInputEncoding unicodeString : config) + (stringProtocol ++ content) -- ------------------------------------------------------------ -- | -- the arrow version of 'readString', the arrow input is the source URI -readFromString :: Attributes -> IOStateArrow s String XmlTree -readFromString userOptions - = applyA ( arr $ readString userOptions ) +readFromString :: SysConfigList -> IOStateArrow s String XmlTree +readFromString config + = applyA ( arr $ readString config ) -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/WriteDocument.hs b/src/Text/XML/HXT/Arrow/WriteDocument.hs --- a/src/Text/XML/HXT/Arrow/WriteDocument.hs +++ b/src/Text/XML/HXT/Arrow/WriteDocument.hs @@ -17,6 +17,7 @@ module Text.XML.HXT.Arrow.WriteDocument ( writeDocument + , writeDocument' , writeDocumentToString , prepareContents ) @@ -28,9 +29,13 @@ import Control.Arrow.ArrowTree import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.Arrow.XmlState.TypeDefs +import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow + ( initialSysState + ) import Text.XML.HXT.Arrow.Edit ( escapeHtmlDoc , escapeXmlDoc , haskellRepOfXmlDoc @@ -40,13 +45,13 @@ , removeDocWhiteSpace , treeRepOfXmlDoc ) - import Text.XML.HXT.Arrow.DocumentOutput ( putXmlDocument , encodeDocument , encodeDocument' ) -- ------------------------------------------------------------ +-- {- | the main filter for writing documents @@ -57,38 +62,39 @@ if @ destination @ is the empty string or \"-\", stdout is used as output device -available options are +for available options see 'Text.XML.HXT.Arrow.XmlState.SystemConfig' -* 'a_indent' : indent document for readability, (default: no indentation) -- 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal) - -- 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8' - -- 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary +- @withOutputXML@ : + (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary add XML processing instruction - and encode document with respect to 'a_output_encoding', - if explicitly switched of, the plain text is issued, this is useful - for non XML output, e.g. generated Haskell code, LaTex, Java, ... + and encode document with respect to output encoding, -- 'a_output_html' : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars +- @withOutputHTML@ : + issue HTML: translate all special XML chars and all HTML chars with a corresponding entity reference + into entity references. Do not generate empty elements, e.g. @@. + The short form introduces trouble in various browsers. -- 'a_no_empty_elements' : do not write the short form \ for empty elements. When 'a_output_html' is set, - the always empty HTML elements are still written in short form, but not the others, as e.g. the script element. - Empty script elements, like \@ instead of @