HaXml 1.23.3 → 1.25.14
raw patch · 51 files changed
Files
- COPYRIGHT +1/−1
- Changelog.md +50/−0
- HaXml.cabal +80/−54
- README +117/−0
- Setup.hs +0/−2
- src/Text/XML/HaXml.hs +1/−4
- src/Text/XML/HaXml/ByteStringPP.hs +21/−9
- src/Text/XML/HaXml/Combinators.hs +99/−16
- src/Text/XML/HaXml/DtdToHaskell/Convert.hs +6/−7
- src/Text/XML/HaXml/DtdToHaskell/Instance.hs +16/−12
- src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs +10/−5
- src/Text/XML/HaXml/Escape.hs +13/−26
- src/Text/XML/HaXml/Html/Generate.hs +9/−10
- src/Text/XML/HaXml/Html/Parse.hs +71/−73
- src/Text/XML/HaXml/Html/ParseLazy.hs +71/−72
- src/Text/XML/HaXml/Html/Pretty.hs +40/−34
- src/Text/XML/HaXml/Lex.hs +76/−70
- src/Text/XML/HaXml/Namespaces.hs +15/−12
- src/Text/XML/HaXml/OneOfN.hs +84/−84
- src/Text/XML/HaXml/Parse.hs +128/−127
- src/Text/XML/HaXml/ParseLazy.hs +128/−128
- src/Text/XML/HaXml/Pretty.hs +13/−2
- src/Text/XML/HaXml/SAX.hs +37/−37
- src/Text/XML/HaXml/Schema/Environment.hs +2/−2
- src/Text/XML/HaXml/Schema/HaskellTypeModel.hs +1/−2
- src/Text/XML/HaXml/Schema/NameConversion.hs +31/−14
- src/Text/XML/HaXml/Schema/Parse.hs +41/−31
- src/Text/XML/HaXml/Schema/PrettyHaskell.hs +35/−30
- src/Text/XML/HaXml/Schema/PrettyHsBoot.hs +14/−10
- src/Text/XML/HaXml/Schema/PrimitiveTypes.hs +10/−8
- src/Text/XML/HaXml/Schema/Schema.hs +5/−6
- src/Text/XML/HaXml/Schema/TypeConversion.hs +212/−92
- src/Text/XML/HaXml/Schema/XSDTypeModel.hs +16/−10
- src/Text/XML/HaXml/ShowXmlLazy.hs +9/−4
- src/Text/XML/HaXml/TypeMapping.hs +17/−17
- src/Text/XML/HaXml/Types.hs +36/−35
- src/Text/XML/HaXml/Validate.hs +17/−17
- src/Text/XML/HaXml/Verbatim.hs +3/−4
- src/Text/XML/HaXml/Version.hs +6/−0
- src/Text/XML/HaXml/Wrappers.hs +7/−6
- src/Text/XML/HaXml/XmlContent.hs +2/−2
- src/Text/XML/HaXml/XmlContent/Haskell.hs +4/−4
- src/Text/XML/HaXml/XmlContent/Parser.hs +8/−8
- src/Text/XML/HaXml/Xtract/Combinators.hs +13/−13
- src/Text/XML/HaXml/Xtract/Lex.hs +3/−3
- src/Text/XML/HaXml/Xtract/Parse.hs +65/−68
- src/tools/DtdToHaskell.hs +11/−11
- src/tools/FpMLToHaskell.hs +56/−52
- src/tools/MkOneOf.hs +20/−20
- src/tools/XsdToHaskell.hs +16/−17
- src/tools/Xtract.hs +15/−14
COPYRIGHT view
@@ -1,6 +1,6 @@ The HaXml library and tools were written by and are copyright to (c) copyright 1998-1999 Malcolm Wallace and Colin Runciman- (c) copyright 2000-2012 Malcolm Wallace+ (c) copyright 2000-2013 Malcolm Wallace The HaXml library is licensed under the terms of the GNU Lesser General Public Licence (LGPL), which can be found in the file called
+ Changelog.md view
@@ -0,0 +1,50 @@+## 1.25.14 (2024-12-12)+- fix inaccuracies in haskell generation code (#17 from @SiriusCourses):+ - Fix mkNamespace for case when QName is recognized at root element+ - Fix QName parser to recognize names with namespaces+ - Prevent multiple declarations after type lifting hoist+ - Inject groups from reference at topElementDecl+ - Fix bug unexcaped module name in generated haskell code+ - Add to Environment deriving for Show and Eq for simpler debug+ - Fix name with dashes for simpleType+- PrettyH*: Add missing pattern match to ppComment (#24 from @e-rk)+- Allow base-4.20 and filepath-1.5; bump CI to GHC 9.8 (#21, @andreasabel)+- allow base-4.22 for ghc-9.12 (#23, @juhp)++## 1.25.13 (2023-07-13)+- correct zero time duration P0S to PT0S (@dten, #16)+- allow ghc-9.6 base (@andreasabel, #15)+- allow bytestring-0.12 (@andreasabel, #18)++## 1.25.12 (2022-10-18)+- Allow parsing empty strings, avoiding space leak #13 (Teo Camarasu)++## 1.25.11 (2022-09-13)+- revert "allow empty text content #10" to avoid haxr memory leak++## 1.25.10 (2022-09-12)+- better pretty printer formatting #8 (Alexander Vieth)+- allow building with GHC 9.4 #9 (Andreas Abel)+- allow empty text content #10 (Teo Camarasu)++## 1.25.9 (2022-04-10)+- fix 1.25.7 regression in Xtract.Parse (#7 by Isaac van Bakel)+- comment typo fixes (#6 by Eric Lindblad)+- include README file++## 1.25.8 (2021-11-22)+- version the License tag in HaXml.cabal as LGPL-2.1 (#3)+- allow building with ghc 9.2 (#4)++## 1.25.7 (2021-10-15)+- many hlint fixes+- fix the rendering of time durations (#1)++## 1.25.6 (2021-09-26)++- GHC 8.8, 8.10, and 9.0 compatibility++## 1.25.5 (2018-10-30)++- GHC-8.4 and GHC-8.6 compatibility+ - Monoids have Semigroup instances
HaXml.cabal view
@@ -1,24 +1,39 @@-name: HaXml-version: 1.23.3-license: LGPL-license-file: COPYRIGHT-author: Malcolm Wallace <Malcolm.Wallace@me.com>-maintainer: author-homepage: http://www.cs.york.ac.uk/fp/HaXml/-category: Text, XML-synopsis: Utilities for manipulating XML documents+cabal-version: 1.18+name: HaXml+version: 1.25.14++license: LGPL-2.1+license-files: COPYRIGHT, LICENCE-GPL, LICENCE-LGPL+author: Malcolm Wallace <Malcolm.Wallace@me.com>+maintainer: Jens Petersen <juhpetersen@gmail.com>+homepage: https://github.com/HaXml/HaXml+bug-reports: https://github.com/HaXml/HaXml/issues+category: Text, XML+synopsis: Utilities for manipulating XML documents description:- Haskell utilities for parsing, filtering, transforming and- generating XML documents.+ Haskell utilities for parsing, filtering, transforming and+ generating XML documents. build-type: Simple-cabal-version: >=1.2-extra-source-files: LICENCE-GPL, LICENCE-LGPL+extra-doc-files: Changelog.md README -flag splitBase- default: True-flag bytestringInBase- default: False+tested-with:+ GHC ==9.8.2+ || ==9.6.6+ || ==9.4.8+ || ==9.2.8+ || ==9.0.2+ || ==8.10.7+ || ==8.8.4+ || ==8.6.5+ || ==8.4.4+ || ==8.2.2+ || ==8.0.2+ || ==7.10.3 +source-repository head+ type: git+ location: https://github.com/HaXml/HaXml.git+ library exposed-modules: Text.XML.HaXml,@@ -55,6 +70,7 @@ Text.XML.HaXml.Util, Text.XML.HaXml.Validate, Text.XML.HaXml.Verbatim,+ Text.XML.HaXml.Version Text.XML.HaXml.Wrappers, Text.XML.HaXml.XmlContent, Text.XML.HaXml.XmlContent.Parser,@@ -66,73 +82,83 @@ exposed-modules: Text.XML.HaXml.Schema.Schema hs-source-dirs: src- build-depends: polyparse >= 1.5, filepath- if flag(splitBase)- build-depends: base >= 3 && < 6, pretty, random, containers- else- build-depends: base < 3- if flag(bytestringInBase)- build-depends: base >= 2 && < 3- else- build-depends: base < 2 || >= 3, bytestring- extensions: CPP, ExistentialQuantification- cpp-options: -DMAJOR=1 -DMINOR=23+ build-depends:+ base >= 4.3.1.0 && < 4.22,+ bytestring >= 0.9.1.10 && < 0.13,+ containers >= 0.4.0.0 && <0.8,+ filepath >= 1.2.0.0 && <1.6,+ pretty >= 1.0.1.2 && <1.2,+ random >= 1.0 && <1.3,+ polyparse >= 1.12.1 && <1.14+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups >= 0.18.5 && < 0.19+ default-language: Haskell98+ default-extensions: CPP, ExistentialQuantification nhc98-options: -K10M+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths Executable Canonicalise GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: Canonicalise.hs+ build-depends: base, HaXml, pretty Executable CanonicaliseLazy GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: CanonicaliseLazy.hs+ build-depends: base, HaXml, pretty Executable Xtract GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: Xtract.hs+ build-depends: base, HaXml, pretty Executable Validate GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: Validate.hs+ build-depends: base, HaXml Executable MkOneOf GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: MkOneOf.hs+ build-depends: base, HaXml Executable DtdToHaskell GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: DtdToHaskell.hs+ build-depends: base, HaXml, pretty Executable XsdToHaskell GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: XsdToHaskell.hs+ build-depends: base, HaXml, pretty, polyparse, directory Executable FpMLToHaskell GHC-Options: -Wall- Extensions: CPP- Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=23+ Default-Language: Haskell98+ Default-Extensions: CPP+ Hs-Source-Dirs: src/tools Main-Is: FpMLToHaskell.hs- build-depends: directory-+ build-depends: base, HaXml, pretty, polyparse, directory
+ README view
@@ -0,0 +1,117 @@+ HaXml - Haskell utilities for processing XML+ --------------------------------------------++Installation instructions:+We currently support nhc98, ghc, and Hugs. The automatic configuration+detects which compilers/interpreters you have, and prepares a build+tree for each. Installation requires write-permission on the system+directories of the compiler/interpreter - the libraries and interfaces+can then be used as "-package HaXml" (for ghc/nhc98 - no extra options+required for Hugs). The standalone tools are installed to a directory of+your choice.++For newer compilers, use Cabal to build and install:++ cabal install++or ++ runhaskell Setup.hs configure+ runhaskell Setup.hs build+ runhaskell Setup.hs install++For older compilers, use the traditional sequence:++ ./configure+ make+ make install++Options to configure are:+ --buildwith=... e.g. ghc-6.2, to build for a specific compiler+ --prefix=... e.g. /usr/local/bin, installation location for HaXml tools++Complaints to: :-)+ Malcolm.Wallace@me.com++P.S.+ For those building on Windows /without/ Cygwin, you can avoid the need+ for configure/make steps by simply running the minimal build script in+ Build.bat+ You will need to edit it for the location of your compiler etc.++----+What this package contains:++ docs/ Some rudimentary HTML documentation about the libraries.+ docs/HaXml/ Haddock-generated API documentation.+ examples/ Some small examples of how the libraries/tools are used.++ src/Text/XML/HaXml/ Numerous support modules for processing XML.+ (The main APIs are as follows:)+ Types.hs Defines a (generic) representation for any XML document.+ Parse.hs Parses an XML document into the generic representation.+ ParseLazy.hs A more space-efficient parser.+ Pretty.hs Pretty-prints an XML document.+ Validate.hs Validates an XML document against a DTD.+ Combinators.hs Provides the combinators described in the ICFP'99 paper+ together with some other useful functions.+ SAX.hs A simple SAX-like stream-event-parser.+ Wrappers.hs Simple top-level wrappers for processing a single+ document using the combinators.+ XmlContent.hs A replacement class for Show/Read, to translate Haskell+ values to/from XML documents. Can be derived by DrIFT+ and/or DtdToHaskell.+ TypeMapping.hs Defines an explicit representation for Haskell types,+ allowing generation of a DTD from a Haskell value.+ OneOfN.hs Some support types (OneOf2 - OneOf20) for code+ generated by tools/DtdToHaskell.++ src/Text/XML/HaXml/Html Extra support modules for processing HTML.+ Parse.hs An error-correcting HTML parser, produces the generic+ XML representation.+ Pretty.hs An HTML-specific pretty-printer.+ Generate.hs Some useful combinators for generating HTML content.++ src/Text/XML/HaXml/Schema Extra support modules for processing Schema.+ XSDTypeModel.hs A representation of the datatype model of+ Xml Schema in terms of XSD concepts.+ HaskellTypeModel.hs A representation of the datatype model of+ Xml Schema in terms of Haskell datatypes.+ Parse.hs Parser from an XSD document to the XSD+ type model above.+ TypeConversion.hs Translate from the XSD model to the Haskell+ model.+ PrettyHaskell.hs Generate Haskell sourcecode from the Haskell+ type model.++ src/tools/ Standalone tools based on the library above.+ DtdToHaskell Translates an XML doc containing a DTD into a Haskell+ module containing data/newtype definitions.+ Xtract A structured 'grep' for XML docs, loosely based on+ the XPath and XQL query languages.+ Validate A simple validation tool for XML docs. Give it a DTD+ file and an XML file, and it reports all validation+ errors it can find.+ Canonicalise A 'cat' filter for XML docs, shows our "standard"+ parsing and pretty-printing behaviour.+ MkOneOf Generates a OneOfN type, given an N, together with+ its required instance of XmlContent. Sometimes types+ larger than OneOf20 are required in code generated by+ DtdToHaskell.+ XsdToHaskell Translates an XSD schema into a Haskell module.+ FpMLToHaskell Translates the set of XSD schemas defining the FpML+ language into a set of Haskell modules.++ src/Text/XML/HaXml/Xtract Internal APIs of the Xtract tool.+ Parse.hs Parse an XPath query to produce a filter.+ Combinators.hs Modified version of the standard combinators.++ src/Text/XML/HaXml/DtdToHaskell Internal APIs of the DtdToHaskell tool.+ TypeDef.hs A representation of the Haskell types corresponding+ to an XML DTD, and a pretty printer for them.+ Convert.hs Convert the standard DTD representation to the+ Haskell-like TypeDef representation.+ Instance.hs Generate appropriate XmlContent class instances for+ the TypeDefs.++----
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
src/Text/XML/HaXml.hs view
@@ -28,10 +28,7 @@ import Text.XML.HaXml.Wrappers (fix2Args,processXmlWith) import Text.XML.HaXml.Verbatim import Text.XML.HaXml.Escape+import Text.XML.HaXml.Version import Text.PrettyPrint.HughesPJ (render) --- | The version of the library.-version :: String-version = show MAJOR.MINOR- -- expect cpp to fill in value
src/Text/XML/HaXml/ByteStringPP.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | This is a fast non-pretty-printer for turning the internal representation -- of generic structured XML documents into Lazy ByteStrings. -- Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in@@ -20,7 +21,12 @@ , cp ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding (maybe,either,elem,concat,(<>))+#else import Prelude hiding (maybe,either,elem,concat)+#endif+ import Data.Maybe hiding (maybe) import Data.List (intersperse) --import Data.ByteString.Lazy hiding (pack,map,head,any,singleton,intersperse,join)@@ -134,12 +140,17 @@ -- | any isText cs = text "<" <> text n <+> fsep (map attribute as) <> -- text ">" <> hcat (map content cs) <> -- text "</" <> qname n <> text ">"- | isText (head cs) = text "<" <> qname n <+> fsep (Prelude.map attribute as) <>+ | isText (head cs) = text "<" <> qname n <> attributes as <> text ">" <> hcat (Prelude.map content cs) <> text "</" <> qname n <> text ">"- | otherwise = let (d,c) = carryelem e empty- in d <> c+ | otherwise = vcat [ text "<" <> qname n <> attributes as <> text ">"+ , nest 2 (vcat (Prelude.map content cs))+ , text "</" <> qname n <> text ">"+ ] +attributes [] = empty+attributes as@(_:_) = text " " <> fsep (Prelude.map attribute as)+ isText :: Content t -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True@@ -151,11 +162,12 @@ text "<" <> qname n <+> fsep (Prelude.map attribute as) , text "/>") carryelem (Elem n as cs) c--- | any isText cs = ( c <> element e, empty)- | otherwise = let (cs0,d0) = carryscan carrycontent cs (text ">")+{- | any isText cs = ( c <> element e, empty)+ | otherwise -} = let (cs0,d0) = carryscan carrycontent cs empty in ( c <>- text "<" <> qname n <+> fsep (Prelude.map attribute as) $$+ text "<" <> qname n <+> fsep (Prelude.map attribute as) <> text ">" $$+ -- This is wrong. It includes the close tag of the previous one nest 2 (vcat cs0) <> --- $$ d0 <> text "</" <> qname n , text ">")@@ -321,11 +333,11 @@ ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> ByteString pubidliteral (PubidLiteral s)- | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"+ | toWord8 '"' `elem` pack s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" systemliteral :: SystemLiteral -> ByteString systemliteral (SystemLiteral s)- | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'"+ | toWord8 '"' `elem` pack s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" chardata, cdsect :: [Char] -> ByteString chardata s = {-if all isSpace s then empty else-} text s@@ -339,5 +351,5 @@ containsDoubleQuote :: [EV] -> Bool containsDoubleQuote evs = any csq evs- where csq (EVString s) = toWord8 '"' `elem` (pack s)+ where csq (EVString s) = toWord8 '"' `elem` pack s csq _ = False
src/Text/XML/HaXml/Combinators.hs view
@@ -32,9 +32,10 @@ -- $recursive , deep, deepest, multi -- ** Interior editing.- , when, guards, chip, inplace, foldXml+ , when, guards, chip, inplace, recursivelyInPlace, foldXml -- ** Constructive filters.- , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs+ -- $constructive+ , mkElem, mkElemAttr, literal, cdata, replaceTag, replaceAttrs, addAttribute -- * C-like conditionals. -- $cond@@ -55,7 +56,7 @@ import Data.Maybe (fromMaybe) infixl 6 `with`, `without`-infixr 5 `o`, `oo`, `union`, `andThen` -- , `orelse`+infixr 5 `o`, `oo`, `union`, `andThen` -- , `orelse` infixl 5 />, </, |>| infixr 4 `when`, `guards` infixr 3 ?>, :>@@ -76,9 +77,9 @@ -- In the algebra of combinators, @none@ is the zero, and @keep@ the identity. -- (They have a more general type than just CFilter.) keep :: a->[a]-keep = \x->[x]+keep x = [x] none :: a->[b]-none = \x->[]+none _ = [] -- | Throw away current node, keep just the (unprocessed) children. children :: CFilter i@@ -120,7 +121,7 @@ tagWith p x@(CElem (Elem n _ _) _) | p (printableName n) = [x] tagWith _ _ = [] -attr n x@(CElem (Elem _ as _) _) | n `elem` (map (printableName.fst) as) = [x]+attr n x@(CElem (Elem _ as _) _) | n `elem` map (printableName.fst) as = [x] attr _ _ = [] attrval av x@(CElem (Elem _ as _) _) | av `elem` as = [x]@@ -143,7 +144,7 @@ -- otherwise it applies the @yes@ filter. iffind :: String -> (String->CFilter i) -> CFilter i -> CFilter i iffind key yes no c@(CElem (Elem _ as _) _) =- case (lookup (N key) as) of+ case lookup (N key) as of Nothing -> no c (Just v@(AttValue _)) -> yes (show v) c iffind _key _yes no other = no other@@ -183,10 +184,10 @@ -- rather than one filter using the result of the other. -- (Has a more general type than just CFilter.) union :: (a->[b]) -> (a->[b]) -> (a->[b])-union = lift (++) -- in Haskell 98: union = lift List.union+union = lift (++) -- in Haskell 98: union = lift List.union where lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d- lift f g h = \x-> f (g x) (h x)+ lift f g h x = f (g x) (h x) -- | Glue a list of filters together. (A list version of union; -- also has a more general type than just CFilter.)@@ -200,10 +201,10 @@ -- works over the same data as the first, but also uses the -- first's result. andThen :: (a->c) -> (c->a->b) -> (a->b)-andThen f g = \x-> g (f x) x -- lift g f id+andThen f g x = g (f x) x -- lift g f id -- | Process children using specified filters.-childrenBy :: CFilter i -> CFilter i +childrenBy :: CFilter i -> CFilter i childrenBy f = f `o` children -- | Directional choice:@@ -240,7 +241,7 @@ -- @path [children, tag \"name1\", attr \"attr1\", children, tag \"name2\"]@ -- is like the XPath query @\/name1[\@attr1]\/name2@. path :: [CFilter i] -> CFilter i-path fs = foldr (flip (o)) keep fs+path fs = foldr (flip o) keep fs -- RECURSIVE SEARCH@@ -263,7 +264,7 @@ -- otherwise the content is discarded. guards :: CFilter i -> CFilter i -> CFilter i f `when` g = g ?> f :> keep-g `guards` f = g ?> f :> none -- = f `o` (keep `with` g)+g `guards` f = g ?> f :> none -- = f `o` (keep `with` g) -- | Process CHildren In Place. The filter is applied to any children -- of an element content, and the element rebuilt around the results.@@ -278,7 +279,14 @@ inplace f c@(CElem (Elem name as _) i) = [ CElem (Elem name as (f c)) i ] inplace _f c = [c] +-- | Recursively process an element in place. That is, the filter is+-- applied to the element itself, then recursively to the results of the+-- filter, all the way to the bottom, then the original element rebuilt+-- around the final results.+recursivelyInPlace :: CFilter i -> CFilter i+recursivelyInPlace f = inplace (recursivelyInPlace f `o` f) + -- | Recursive application of filters: a fold-like operator. Defined -- as @f `o` chip (foldXml f)@. foldXml :: CFilter i -> CFilter i@@ -288,11 +296,15 @@ -- CONSTRUCTIVE CONTENT FILTERS+--+-- $constructive+-- The constructive filters are primitive filters for building new elements,+-- or editing existing elements. -- | Build an element with the given tag name - its content is the results -- of the given list of filters. mkElem :: String -> [CFilter i] -> CFilter i-mkElem h cfs = \t-> [ CElem (Elem (N h) [] (cat cfs t)) undefined ]+mkElem h cfs t = [ CElem (Elem (N h) [] (cat cfs t)) undefined ] -- | Build an element with the given name, attributes, and content. mkElemAttr :: String -> [(String,CFilter i)] -> [CFilter i] -> CFilter i@@ -321,10 +333,81 @@ where as' = map (\(n,v)-> (N n, AttValue [Left v])) as replaceAttrs _ _ = [] +-- | Add the desired attribute name and value to the topmost element,+-- without changing the element in any other way.+addAttribute :: String -> String -> CFilter a+addAttribute name val (CElem (Elem n as cs) i) =+ [CElem (Elem n (a:as) cs) i]+ where a = (N name, AttValue [Left val])+addAttribute _ _ _ = [] + -- LABELLING+-- $labelling+-- LabelFilters are a way of annotating the results of a filter operation+-- with some arbitrary values drawn from the tree values. Typically, the+-- annotations are then consumed by a label-processing filter (of+-- type @a -> CFilter@). This is useful way of passing information between+-- sections of the tree as you process it. An example may help to explain.+--+-- Let's say we want to add an attribute to every node of the tree,+-- containing a textual representation of its path from the root,+-- e.g. "/foo/bar/quux". Where there are multiple identically-tagged elements+-- under the same parent node of the original tree, we expect them to have+-- a distinguishing attribute called "name".+--+-- Step one. Given the path prefix to this node, how do we add the "xpath"+-- attribute?+--+-- > annotateOne :: String -> CFilter a+-- > annotateOne prefix =+-- > (f `oo` ((tagged `x` attributed "name") (attr "name")))+-- > |>|+-- > (g `oo` (tagged keep))+-- > where+-- > f (tag,att) = addAttribute "xpath" (prefix++"/"++tag++"["++att++"]")+-- > g tag = addAttribute "xpath" (prefix++"/"++tag)@+--+-- First, the @attr "name"@ filter distinguishes whether this node contains+-- the attribute, hence choosing whether the left or right branch of the+-- @|>|@ is taken. If the attribute is /not/ present, then the LabelFilter+-- @tagged keep@ selects the current node, and annotates it with the+-- tagname of the element. The @oo@ applies the label-consuming function @g@+-- to the result, and this injects the "xpath" attribute by suffixing+-- the tagname to the known path prefix.+--+-- If the "name" attribute /is/ present, then there are /two/ labelling filters+-- applied to the current node, annotating it with the pair of its tag+-- and the value of the attribute "name". The label-consuming function @f@ is+-- applied to the pair with @oo@, to inject the "xpath" attribute with a more+-- complex representation of its path.+--+-- Step two. Recursively apply the annotation throughout the tree.+--+-- > labelAllPaths :: CFilter a+-- > labelAllPaths = allPaths `o` initialise+-- > where+-- > initialise = annotateOne "/"+-- >+-- > allPaths :: CFilter a+-- > allPaths = inplace ( allPaths+-- > `o`+-- > (\prefix-> annotateOne prefix `o` children)+-- > `oo`+-- > (attributed "xpath" keep)+-- > )+--+-- In order to apply @annotateOne@ to any node, we need to know the path+-- prefix thus far into the tree. So, we read the "xpath" attribute from+-- the current node (assumed to have already been processed) as a+-- LabelFilter, then consume the label by passing it to @annotateOne@ on+-- the children of the current node. Using @inplace@ rebuilds the processed+-- children into the current node, after recursively dealing with their+-- children. ++ -- | A LabelFilter is like a CFilter except that it pairs up a polymorphic -- value (label) with each of its results. type LabelFilter i a = Content i -> [(a,Content i)]@@ -380,7 +463,7 @@ attributed :: String -> CFilter i -> LabelFilter i String attributed key f = extracted att f where att (CElem (Elem _ as _) _) =- case (lookup (N key) as) of+ case lookup (N key) as of Nothing -> "" (Just v@(AttValue _)) -> show v att _ = ""@@ -395,7 +478,7 @@ -- | Label each content with some information extracted from itself. extracted :: (Content i->a) -> CFilter i -> LabelFilter i a extracted proj f = concatMap (\c->[(proj c, c)]) . f- + {-
src/Text/XML/HaXml/DtdToHaskell/Convert.hs view
@@ -9,7 +9,7 @@ ( dtd2TypeDef ) where -import Data.List (intersperse,nub)+import Data.List (intercalate,nub) import Text.XML.HaXml.Types hiding (Name) import Text.XML.HaXml.DtdToHaskell.TypeDef@@ -25,8 +25,8 @@ ---- Apparently multiple ATTLIST decls for the same element are permitted, ---- although only one ELEMENT decl for it is allowed. dtd2TypeDef :: [MarkupDecl] -> [TypeDef]-dtd2TypeDef mds =- (concatMap convert . reverse . database []) mds+dtd2TypeDef =+ concatMap convert . reverse . database [] where database db [] = db database db (m:ms) =@@ -94,16 +94,16 @@ mkData tss fs aux n = [DataDef aux n fs (map (mkConstr n) tss)] where mkConstr m ts = (mkConsName m ts, ts)- mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))+ mkConsName (Name x m) sts = Name x (m++intercalate "_" (map flatten sts)) flatten (Maybe st) = {-"Maybe_" ++ -} flatten st flatten (List st) = {-"List_" ++ -} flatten st flatten (List1 st) = {-"List1_" ++ -} flatten st flatten (Tuple sts) = {-"Tuple" ++ show (length sts) ++ "_" ++ -}- concat (intersperse "_" (map flatten sts))+ intercalate "_" (map flatten sts) flatten StringMixed = "Str" flatten String = "Str" flatten (OneOf sts) = {-"OneOf" ++ show (length sts) ++ "_" ++ -}- concat (intersperse "_" (map flatten sts))+ intercalate "_" (map flatten sts) flatten Any = "Any" flatten (Defined (Name _ m)) = m @@ -132,4 +132,3 @@ mkType (EnumeratedType _) IMPLIED = Maybe (Defined (name_a e n)) mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) = Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))-
src/Text/XML/HaXml/DtdToHaskell/Instance.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE CPP #-} module Text.XML.HaXml.DtdToHaskell.Instance ( mkInstance ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+ import Data.List (intersperse) import Text.XML.HaXml.DtdToHaskell.TypeDef@@ -56,7 +61,7 @@ nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\"" <> ppXName n <> text "\"]" $$ text "; interior e $"- <+> (mkParseConstr frattr (n0,sts))+ <+> mkParseConstr frattr (n0,sts) $$ text "} `adjustErr` (\"in <" <> ppXName n <> text ">, \"++)") )@@ -83,7 +88,7 @@ mkInstance (DataDef False n fs cs) = let _ = nameSupply cs (frpat, frattr, topat, toattr) = attrpats fs- _ = if null fs then False else True+ _ = not (null fs) in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )@@ -110,7 +115,7 @@ mkInstance (DataDef True n fs cs) = let _ = nameSupply cs (_, frattr, _, _) = attrpats fs- mixattrs = if null fs then False else True+ mixattrs = not (null fs) in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" )@@ -239,9 +244,9 @@ (List1 _) -> ap <+> text "parseContents" (Tuple _) -> ap <+> text "parseContents" (OneOf _) -> ap <+> text "parseContents"- (StringMixed) -> ap <+> text "text"- (String) -> ap <+> text "(text `onFail` return \"\")"- (Any) -> ap <+> text "parseContents"+ StringMixed -> ap <+> text "text"+ String -> ap <+> text "(text `onFail` return \"\")"+ Any -> ap <+> text "parseContents" (Defined _) -> ap <+> text "parseContents" (Defaultable _ _) -> ap <+> text "nyi_fromElem_Defaultable" @@ -260,9 +265,9 @@ (List1 _) -> text "toContents" <+> v (Tuple _) -> text "toContents" <+> v (OneOf _) -> text "toContents" <+> v- (StringMixed) -> text "toText" <+> v- (String) -> text "toText" <+> v- (Any) -> text "toContents" <+> v+ StringMixed -> text "toText" <+> v+ String -> text "toText" <+> v+ Any -> text "toContents" <+> v (Defined _) -> text "toContents" <+> v (Defaultable _ _) -> text "nyi_toElem_Defaultable" <+> v @@ -275,8 +280,8 @@ nameSupply :: [b] -> [Doc] nameSupply ss = take (length ss) (map char ['a'..'z']- ++ map text [ a:n:[] | n <- ['0'..'9']- , a <- ['a'..'z'] ])+ ++ [ text [a,n] | n <- ['0'..'9']+ , a <- ['a'..'z'] ]) -- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]] mkTranslate :: [Name] -> Doc@@ -394,4 +399,3 @@ text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "=" $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName tag <> text "\")"<+> attrexp <+> parens (mkToElem sts vs) <+> text ") ()]")-
src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | Defines an internal representation of Haskell data\/newtype definitions -- that correspond to the XML DTD types, and provides pretty-printers to -- convert these types into the 'Doc' type of "Text.PrettyPrint.HughesPJ".@@ -18,6 +19,10 @@ , name, name_, name_a, name_ac, name_f, mangle, manglef ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+ import Data.Char (isLower, isUpper, toLower, toUpper, isDigit) import Data.List (intersperse) import Text.PrettyPrint.HughesPJ@@ -45,8 +50,8 @@ | Tuple [StructType] | OneOf [StructType] | Any -- ^ XML's contentspec allows ANY- | StringMixed -- ^ mixed (#PCDATA | ... )*- | String -- ^ string only (#PCDATA)+ | StringMixed -- ^ mixed (#PCDATA | ... )*+ | String -- ^ string only (#PCDATA) | Defined Name deriving Eq @@ -64,9 +69,9 @@ . foldr1 (.) (intersperse (showChar '|') (map shows ss)) . showChar ')'- showsPrec _ (Any) = showString "ANY"- showsPrec _ (StringMixed) = showString "#PCDATA"- showsPrec _ (String) = showString "#PCDATA"+ showsPrec _ Any = showString "ANY"+ showsPrec _ StringMixed = showString "#PCDATA"+ showsPrec _ String = showString "#PCDATA" showsPrec _ (Defined (Name n _)) = showString n
src/Text/XML/HaXml/Escape.hs view
@@ -111,16 +111,13 @@ (escapeContent xmlEscaper content) escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]-escapeAttributes xmlEscaper atts =- map- (\ (name,av) -> (name,escapeAttValue xmlEscaper av))- atts+escapeAttributes xmlEscaper =+ map (\ (name,av) -> (name,escapeAttValue xmlEscaper av)) escapeAttValue :: XmlEscaper -> AttValue -> AttValue escapeAttValue xmlEscaper (AttValue attValList) = AttValue (- concat (- map+ concatMap (\ av -> case av of Right _ -> [av] Left s ->@@ -134,13 +131,11 @@ s ) attValList- ) ) escapeContent :: XmlEscaper -> [Content i] -> [Content i]-escapeContent xmlEscaper contents =- concat- (map+escapeContent xmlEscaper =+ concatMap (\ content -> case content of (CString b str i) -> map@@ -154,8 +149,6 @@ (CElem element i) -> [CElem (escapeElement xmlEscaper element) i] _ -> [content] )- contents- ) mkEscape :: XmlEscaper -> Char -> Reference mkEscape (XmlEscaper {toEscape = toescape}) ch =@@ -184,10 +177,8 @@ (unEscapeContent xmlEscaper content) unEscapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]-unEscapeAttributes xmlEscaper atts =- map- (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av))- atts+unEscapeAttributes xmlEscaper =+ map (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av)) unEscapeAttValue :: XmlEscaper -> AttValue -> AttValue unEscapeAttValue xmlEscaper (AttValue attValList) =@@ -203,7 +194,7 @@ ) unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]-unEscapeContent xmlEscaper content =+unEscapeContent xmlEscaper = map (\ cntnt -> case cntnt of CRef ref i -> case unEscapeChar xmlEscaper ref of@@ -212,7 +203,6 @@ CElem element i -> CElem (unEscapeElement xmlEscaper element) i _ -> cntnt )- content unEscapeChar :: XmlEscaper -> Reference -> Maybe Char unEscapeChar xmlEscaper ref =@@ -230,25 +220,23 @@ Elem name (compressAttributes attributes) (compressContent content) compressAttributes :: [(QName,AttValue)] -> [(QName,AttValue)]-compressAttributes atts =- map- (\ (name,av) -> (name,compressAttValue av))- atts+compressAttributes =+ map (\ (name,av) -> (name,compressAttValue av)) compressAttValue :: AttValue -> AttValue compressAttValue (AttValue l) = AttValue (compress l) where compress :: [Either String Reference] -> [Either String Reference] compress [] = []- compress (Right ref : es) = Right ref : (compress es)- compress ( (ls @ (Left s1)) : es) =+ compress (Right ref : es) = Right ref : compress es+ compress ( ls@(Left s1) : es) = case compress es of (Left s2 : es2) -> Left (s1 ++ s2) : es2 es2 -> ls : es2 compressContent :: [Content i] -> [Content i] compressContent [] = []-compressContent ((csb @ (CString b1 s1 i1)) : cs) =+compressContent (csb@(CString b1 s1 i1) : cs) = case compressContent cs of (CString b2 s2 _) : cs2 | b1 == b2@@ -288,4 +276,3 @@ fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes), isEscape = isescape }-
src/Text/XML/HaXml/Html/Generate.hs view
@@ -137,14 +137,14 @@ -- ( Pretty.text "</" Pretty.<> -- Pretty.text n Pretty.<> -- Pretty.text ">" )- Pretty.fcat [ ( Pretty.text "<" Pretty.<>- Pretty.text (printableName n) Pretty.<>- attrs as Pretty.<>- Pretty.text ">")+ Pretty.fcat [ Pretty.text "<" Pretty.<>+ Pretty.text (printableName n) Pretty.<>+ attrs as Pretty.<>+ Pretty.text ">" , Pretty.nest 4 (htmlprint cs)- , ( Pretty.text "</" Pretty.<>- Pretty.text (printableName n) Pretty.<>- Pretty.text ">" )+ , Pretty.text "</" Pretty.<>+ Pretty.text (printableName n) Pretty.<>+ Pretty.text ">" ] attrs = Pretty.cat . map attribute@@ -171,6 +171,5 @@ keepUntil p xs = select p ([],xs) where select _ (ls,[]) = (ls,[])- select q (ls,(y:ys)) | q y = (ls,y:ys)- | otherwise = select q (y:ls,ys)-+ select q (ls,y:ys) | q y = (ls,y:ys)+ | otherwise = select q (y:ls,ys)
src/Text/XML/HaXml/Html/Parse.hs view
@@ -26,7 +26,7 @@ import Text.ParserCombinators.Poly.Plain -- #define DEBUG- + #if defined(DEBUG) # if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)@@ -54,7 +54,7 @@ -- contents of the file. The result is the generic representation of -- an XML document. Any parsing errors are returned in the @Either@ type. htmlParse' :: String -> String -> Either String (Document Posn)-htmlParse' file = Prelude.either Left (Right . simplify) . fst+htmlParse' file = fmap simplify . fst . runParser document . xmlLex file ---- Document simplification ----@@ -115,7 +115,7 @@ "form" `closes` "form" = True "label" `closes` "label" = True _ `closes` "option" = True-"thead" `closes` t | t `elem` ["colgroup"] = True+"thead" `closes` t | t == "colgroup" = True "tfoot" `closes` t | t `elem` ["thead","colgroup"] = True "tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True "colgroup" `closes` "colgroup" = True@@ -141,8 +141,8 @@ name :: HParser Name --name = do {(p,TokName s) <- next; return s} name = do (p,tok) <- next- case tok of - TokName s -> return s + case tok of+ TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok @@ -156,13 +156,13 @@ maybe :: HParser a -> HParser (Maybe a) maybe p =- ( p >>= return . Just) `onFail`- ( return Nothing)+ (Just <$> p) `onFail`+ return Nothing either :: HParser a -> HParser b -> HParser (Either a b) either p q =- ( p >>= return . Left) `onFail`- ( q >>= return . Right)+ (Left <$> p) `onFail`+ (Right <$> q) word :: String -> HParser () word s = do { x <- next@@ -180,7 +180,7 @@ } `onFail` return noPos nmtoken :: HParser NmToken-nmtoken = (string `onFail` freetext)+nmtoken = string `onFail` freetext failP, failBadP :: String -> HParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) }@@ -223,7 +223,7 @@ cdsect :: HParser CDSect cdsect = do tok TokSectionOpen- bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata+ bracket (tok (TokSection CDATAx)) (commit $ tok TokSectionClose) chardata prolog :: HParser Prolog prolog = do@@ -236,7 +236,7 @@ xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -250,14 +250,14 @@ versioninfo :: HParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual- bracket (tok TokQuote) (tok TokQuote) freetext+ bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: HParser Misc-misc = - oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+misc =+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] @@ -271,18 +271,18 @@ commit $ do n <- qname eid <- maybe externalid--- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)+-- es <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose)) (many markupdecl) tok TokAnyClose `onFail` failP "missing > in DOCTYPE decl" -- return (DTD n eid (case es of { Nothing -> []; Just e -> e })) return (DTD n eid []) --markupdecl :: HParser MarkupDecl --markupdecl =--- ( elementdecl >>= return . Element) `onFail`--- ( attlistdecl >>= return . AttList) `onFail`--- ( entitydecl >>= return . Entity) `onFail`--- ( notationdecl >>= return . Notation) `onFail`--- ( misc >>= return . MarkupMisc) `onFail`+-- (Element <$> elementdecl) `onFail`+-- (AttList <$> attlistdecl) `onFail`+-- (Entity <$> entitydecl) `onFail`+-- (Notation <$> notationdecl) `onFail`+-- (MarkupMisc <$> misc) `onFail` -- PEREF(MarkupPE,markupdecl) -- --extsubset :: HParser ExtSubset@@ -293,16 +293,16 @@ -- --extsubsetdecl :: HParser ExtSubsetDecl --extsubsetdecl =--- ( markupdecl >>= return . ExtMarkupDecl) `onFail`--- ( conditionalsect >>= return . ExtConditionalSect) `onFail`+-- (ExtMarkupDecl <$> markupdecl) `onFail`+-- (ExtConditionalSect <$> conditionalsect) `onFail` -- PEREF(ExtPEReference,extsubsetdecl) sddecl :: HParser SDDecl sddecl = do- (word "standalone" `onFail` word "STANDALONE")+ word "standalone" `onFail` word "STANDALONE" commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl"- bracket (tok TokQuote) (tok TokQuote)+ bracket (tok TokQuote) (commit $ tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" )@@ -323,33 +323,33 @@ (ElemTag (N e) avs) <- elemtag ( if e `closes` ctx then -- insert the missing close-tag, fail forward, and reparse.- ( do debug ("/")+ ( do debug "/" unparse ([TokEndOpen, TokName ctx, TokAnyClose, TokAnyOpen, TokName e] ++ reformatAttrs avs) return ([], Elem (N "null") [] [])) else if e `elem` selfclosingtags then -- complete the parse straightaway.- ( do tok TokEndClose -- self-closing <tag /> + ( do tok TokEndClose -- self-closing <tag /> debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail`- -- ( do tok TokAnyClose -- sequence <tag></tag> (**not HTML?**)+ -- ( do tok TokAnyClose -- sequence <tag></tag> (**not HTML?**) -- debug (e++"[+")- -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname+ -- n <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname -- debug "]"- -- if e == (map toLower n :: Name) - -- then return ([], Elem e avs []) + -- if e == (map toLower n :: Name)+ -- then return ([], Elem e avs []) -- else return (error "no nesting in empty tag")) `onFail`- ( do tok TokAnyClose -- <tag> with no close (e.g. <IMG>)+ ( do tok TokAnyClose -- <tag> with no close (e.g. <IMG>) debug (e++"[+]") return ([], Elem (N e) avs [])) else- (( do tok TokEndClose+ ( do tok TokEndClose debug (e++"[]") return ([], Elem (N e) avs [])) `onFail` ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag" debug (e++"[") -- zz <- many (content e)- -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname+ -- n <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname zz <- manyFinally (content e) (tok TokEndOpen) (N n) <- qname@@ -364,8 +364,8 @@ else do unparse [TokEndOpen, TokName n, TokAnyClose] debug "-"- return (((e,avs):s), Elem (N e) avs cs))- ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))+ return ((e,avs):s, Elem (N e) avs cs))+ ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)) closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])] closeInner c ts =@@ -378,12 +378,12 @@ reparse (zip (repeat p) ts) reformatAttrs :: [(QName, AttValue)] -> [TokenT]-reformatAttrs avs = concatMap f0 avs+reformatAttrs = concatMap f0 where f0 (a, v@(AttValue _)) = [ TokName (printableName a), TokEqual , TokQuote, TokFreeText (show v), TokQuote ] reformatTags :: [(String, [(QName, AttValue)])] -> [TokenT]-reformatTags ts = concatMap f0 ts+reformatTags = concatMap f0 where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose] content :: Name -> HParser (Stack,Content Posn)@@ -408,7 +408,7 @@ (N n) <- qname v <- (do tok TokEqual attvalue) `onFail`- (return (AttValue [Left "TRUE"]))+ return (AttValue [Left "TRUE"]) return (N $ map toLower n, v) --elementdecl :: HParser ElementDecl@@ -424,8 +424,8 @@ --contentspec = -- ( word "EMPTY" >> return EMPTY) `onFail` -- ( word "ANY" >> return ANY) `onFail`--- ( mixed >>= return . Mixed) `onFail`--- ( cp >>= return . ContentSpec) `onFail`+-- (Mixed <$> mixed) `onFail`+-- (ContentSpec <$> cp) `onFail` -- PEREF(ContentPE,contentspec) -- --choice :: HParser [CP]@@ -492,8 +492,8 @@ --atttype :: HParser AttType --atttype = -- ( word "CDATA" >> return StringType) `onFail`--- ( tokenizedtype >>= return . TokenizedType) `onFail`--- ( enumeratedtype >>= return . EnumeratedType)+-- (TokenizedType <$> tokenizedtype) `onFail`+-- (EnumeratedType <$> enumeratedtype) -- --tokenizedtype :: HParser TokenizedType --tokenizedtype =@@ -507,8 +507,8 @@ -- --enumeratedtype :: HParser EnumeratedType --enumeratedtype =--- ( notationtype >>= return . NotationType) `onFail`--- ( enumeration >>= return . Enumeration)+-- (NotationType <$> notationtype) `onFail`+-- (Enumeration <$> enumeration) -- --notationtype :: HParser NotationType --notationtype = do@@ -555,7 +555,7 @@ -- return (IgnoreSectContents i is) -- --ignore :: HParser Ignore---ignore = freetext >>= return . Ignore+--ignore = Ignore <$> freetext reference :: HParser Reference reference = do@@ -570,17 +570,17 @@ {- reference :: HParser Reference reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ (RefChar <$> charref) `onFail`+ (RefEntity <$> entityref) entityref :: HParser EntityRef entityref = do- n <- bracket (tok TokAmp) (tok TokSemi) name+ n <- bracket (tok TokAmp) (commit $ tok TokSemi) name return n charref :: HParser CharRef charref = do- bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)+ bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i@@ -593,8 +593,8 @@ -- --entitydecl :: HParser EntityDecl --entitydecl =--- ( gedecl >>= return . EntityGEDecl) `onFail`--- ( pedecl >>= return . EntityPEDecl)+-- (EntityGEDecl <$> gedecl) `onFail`+-- (EntityPEDecl <$> pedecl) -- --gedecl :: HParser GEDecl --gedecl = do@@ -617,25 +617,24 @@ -- --entitydef :: HParser EntityDef --entitydef =--- ( entityvalue >>= return . DefEntityValue) `onFail`+-- (DefEntityValue <$> entityvalue) `onFail` -- ( do eid <- externalid -- ndd <- maybe ndatadecl -- return (DefExternalID eid ndd)) -- --pedef :: HParser PEDef --pedef =--- ( entityvalue >>= return . PEDefEntityValue) `onFail`--- ( externalid >>= return . PEDefExternalID)+-- (PEDefEntityValue <$> entityvalue) `onFail`+-- (PEDefExternalID <$> externalid) externalid :: HParser ExternalID externalid = ( do word "SYSTEM"- s <- systemliteral- return (SYSTEM s)) `onFail`+ SYSTEM <$> systemliteral) `onFail` ( do word "PUBLIC" p <- pubidliteral- s <- (systemliteral `onFail` return (SystemLiteral ""))- return (PUBLIC p s))+ PUBLIC p <$> systemliteral `onFail` return (SystemLiteral "")+ ) --ndatadecl :: HParser NDataDecl --ndatadecl = do@@ -666,9 +665,9 @@ encodingdecl :: HParser EncodingDecl encodingdecl = do- (word "encoding" `onFail` word "ENCODING")+ word "encoding" `onFail` word "ENCODING" tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"- f <- bracket (tok TokQuote) (tok TokQuote) freetext+ f <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (EncodingDecl f) --notationdecl :: HParser NotationDecl@@ -688,18 +687,18 @@ --entityvalue :: HParser EntityValue --entityvalue = do--- evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)+-- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many ev) -- return (EntityValue evs) --ev :: HParser EV --ev =--- ( freetext >>= return . EVString) `onFail`+-- (EVString <$> freetext) `onFail` -- -- PEREF(EVPERef,ev) `onFail`--- ( reference >>= return . EVRef)+-- (EVRef <$> reference) attvalue :: HParser AttValue attvalue =- ( do avs <- bracket (tok TokQuote) (tok TokQuote)+ ( do avs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) ) `onFail` ( do v <- nmtoken@@ -714,14 +713,13 @@ systemliteral :: HParser SystemLiteral systemliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext- return (SystemLiteral s) -- note: need to fold &...; escapes+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext+ return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext- return (PubidLiteral s) -- note: need to fold &...; escapes+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext+ return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData-chardata = freetext -- >>= return . CharData-+chardata = freetext -- <&> CharData
src/Text/XML/HaXml/Html/ParseLazy.hs view
@@ -114,7 +114,7 @@ "form" `closes` "form" = True "label" `closes` "label" = True _ `closes` "option" = True-"thead" `closes` t | t `elem` ["colgroup"] = True+"thead" `closes` t | t == "colgroup" = True "tfoot" `closes` t | t `elem` ["thead","colgroup"] = True "tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True "colgroup" `closes` "colgroup" = True@@ -139,8 +139,8 @@ name :: HParser Name --name = do {(p,TokName s) <- next; return s} name = do (p,tok) <- next- case tok of - TokName s -> return s + case tok of+ TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok @@ -154,13 +154,13 @@ maybe :: HParser a -> HParser (Maybe a) maybe p =- ( p >>= return . Just) `onFail`- ( return Nothing)+ (Just <$> p) `onFail`+ return Nothing either :: HParser a -> HParser b -> HParser (Either a b) either p q =- ( p >>= return . Left) `onFail`- ( q >>= return . Right)+ (Left <$> p) `onFail`+ (Right <$> q) word :: String -> HParser () word s = do { x <- next@@ -178,7 +178,7 @@ } `onFail` return noPos nmtoken :: HParser NmToken-nmtoken = (string `onFail` freetext)+nmtoken = string `onFail` freetext failP, failBadP :: String -> HParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) }@@ -198,12 +198,12 @@ document = do return Document `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++))- `apply` (return emptyST)+ `apply` return emptyST `apply` (do ht <- many1 (element (N "HTML document")) return (case map snd ht of [e] -> e es -> Elem (N "html") [] (map mkCElem es)))- `apply` (many misc)+ `apply` many misc where mkCElem e = CElem e noPos comment :: HParser Comment@@ -222,7 +222,7 @@ cdsect :: HParser CDSect cdsect = do tok TokSectionOpen- bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata+ bracket (tok (TokSection CDATAx)) (commit $ tok TokSectionClose) chardata prolog :: HParser Prolog prolog = do@@ -235,7 +235,7 @@ xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -249,14 +249,14 @@ versioninfo :: HParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual- bracket (tok TokQuote) (tok TokQuote) freetext+ bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: HParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] @@ -270,18 +270,18 @@ commit $ do n <- qname eid <- maybe externalid--- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl)+-- es <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose)) (many markupdecl) tok TokAnyClose `onFail` failP "missing > in DOCTYPE decl" -- return (DTD n eid (case es of { Nothing -> []; Just e -> e })) return (DTD n eid []) --markupdecl :: HParser MarkupDecl --markupdecl =--- ( elementdecl >>= return . Element) `onFail`--- ( attlistdecl >>= return . AttList) `onFail`--- ( entitydecl >>= return . Entity) `onFail`--- ( notationdecl >>= return . Notation) `onFail`--- ( misc >>= return . MarkupMisc) `onFail`+-- (Element <$> elementdecl) `onFail`+-- (AttList <$> attlistdecl) `onFail`+-- (Entity <$> entitydecl) `onFail`+-- (Notation <$> notationdecl) `onFail`+-- (MarkupMisc <$> misc) `onFail` -- PEREF(MarkupPE,markupdecl) -- --extsubset :: HParser ExtSubset@@ -292,16 +292,16 @@ -- --extsubsetdecl :: HParser ExtSubsetDecl --extsubsetdecl =--- ( markupdecl >>= return . ExtMarkupDecl) `onFail`--- ( conditionalsect >>= return . ExtConditionalSect) `onFail`+-- (ExtMarkupDecl <$> markupdecl) `onFail`+-- (ExtConditionalSect <$> conditionalsect) `onFail` -- PEREF(ExtPEReference,extsubsetdecl) sddecl :: HParser SDDecl sddecl = do- (word "standalone" `onFail` word "STANDALONE")+ word "standalone" `onFail` word "STANDALONE" commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl"- bracket (tok TokQuote) (tok TokQuote)+ bracket (tok TokQuote) (commit $ tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" )@@ -322,29 +322,29 @@ (ElemTag (N e) avs) <- elemtag ( if e `closes` ctx then -- insert the missing close-tag, fail forward, and reparse.- ( do debug ("/")+ ( do debug "/" unparse ([TokEndOpen, TokName ctx, TokAnyClose, TokAnyOpen, TokName e] ++ reformatAttrs avs) return ([], Elem (N "null") [] [])) else if e `elem` selfclosingtags then -- complete the parse straightaway.- ( do tok TokEndClose -- self-closing <tag />+ ( do tok TokEndClose -- self-closing <tag /> debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail`- -- ( do tok TokAnyClose -- sequence <tag></tag> (**not HTML?**)+ -- ( do tok TokAnyClose -- sequence <tag></tag> (**not HTML?**) -- debug (e++"[+")- -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname+ -- n <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname -- debug "]" -- if e == (map toLower n :: Name) -- then return ([], Elem e avs []) -- else return (error "no nesting in empty tag")) `onFail`- ( do tok TokAnyClose -- <tag> with no close (e.g. <IMG>)+ ( do tok TokAnyClose -- <tag> with no close (e.g. <IMG>) debug (e++"[+]") return ([], Elem (N e) avs [])) else- (( do tok TokEndClose- debug (e++"[]")- return ([], Elem (N e) avs [])) `onFail`+ ( do tok TokEndClose+ debug (e++"[]")+ return ([], Elem (N e) avs [])) `onFail` ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag" debug (e++"[") return (\ interior-> let (stack,contained) = interior@@ -364,8 +364,8 @@ else do unparse [TokEndOpen, TokName n, TokAnyClose] debug "-"- return (((e,avs):s), cs)))- ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)))+ return ((e,avs):s, cs)))+ ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx)) closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])] closeInner c ts =@@ -378,12 +378,12 @@ reparse (zip (repeat p) ts) reformatAttrs :: [(QName, AttValue)] -> [TokenT]-reformatAttrs avs = concatMap f0 avs+reformatAttrs = concatMap f0 where f0 (N a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote, TokFreeText (show v), TokQuote] reformatTags :: [(Name, [(QName, AttValue)])] -> [TokenT]-reformatTags ts = concatMap f0 ts+reformatTags = concatMap f0 where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs ++[TokAnyClose] @@ -409,7 +409,7 @@ (N n) <- qname v <- (do tok TokEqual attvalue) `onFail`- (return (AttValue [Left "TRUE"]))+ return (AttValue [Left "TRUE"]) return (N (map toLower n), v) --elementdecl :: HParser ElementDecl@@ -425,8 +425,8 @@ --contentspec = -- ( word "EMPTY" >> return EMPTY) `onFail` -- ( word "ANY" >> return ANY) `onFail`--- ( mixed >>= return . Mixed) `onFail`--- ( cp >>= return . ContentSpec) `onFail`+-- (Mixed <$> mixed) `onFail`+-- (ContentSpec <$> cp) `onFail` -- PEREF(ContentPE,contentspec) -- --choice :: HParser [CP]@@ -493,8 +493,8 @@ --atttype :: HParser AttType --atttype = -- ( word "CDATA" >> return StringType) `onFail`--- ( tokenizedtype >>= return . TokenizedType) `onFail`--- ( enumeratedtype >>= return . EnumeratedType)+-- (TokenizedType <$> tokenizedtype) `onFail`+-- (EnumeratedType <$> enumeratedtype) -- --tokenizedtype :: HParser TokenizedType --tokenizedtype =@@ -508,18 +508,18 @@ -- --enumeratedtype :: HParser EnumeratedType --enumeratedtype =--- ( notationtype >>= return . NotationType) `onFail`--- ( enumeration >>= return . Enumeration)+-- (NotationType <$> notationtype) `onFail`+-- (Enumeration <$> enumeration) -- --notationtype :: HParser NotationType --notationtype = do -- word "NOTATION"--- bracket (tok TokBraOpen) (tok TokBraClose)+-- bracket (tok TokBraOpen) (commit $ tok TokBraClose) -- (name `sepby1` (tok TokPipe)) -- --enumeration :: HParser Enumeration --enumeration =--- bracket (tok TokBraOpen) (tok TokBraClose)+-- bracket (tok TokBraOpen) (commit $ tok TokBraClose) -- (nmtoken `sepby1` (tok TokPipe)) -- --defaultdecl :: HParser DefaultDecl@@ -556,7 +556,7 @@ -- return (IgnoreSectContents i is) -- --ignore :: HParser Ignore---ignore = freetext >>= return . Ignore+--ignore = Ignore <$> freetext reference :: HParser Reference reference = do@@ -571,17 +571,17 @@ {- reference :: HParser Reference reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ (RefChar <$> charref) `onFail`+ (RefEntity <$> entityref) entityref :: HParser EntityRef entityref = do- n <- bracket (tok TokAmp) (tok TokSemi) name+ n <- bracket (tok TokAmp) (commit $ tok TokSemi) name return n charref :: HParser CharRef charref = do- bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)+ bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i@@ -594,8 +594,8 @@ -- --entitydecl :: HParser EntityDecl --entitydecl =--- ( gedecl >>= return . EntityGEDecl) `onFail`--- ( pedecl >>= return . EntityPEDecl)+-- (EntityGEDecl <$> gedecl) `onFail`+-- (EntityPEDecl <$> pedecl) -- --gedecl :: HParser GEDecl --gedecl = do@@ -618,24 +618,24 @@ -- --entitydef :: HParser EntityDef --entitydef =--- ( entityvalue >>= return . DefEntityValue) `onFail`+-- (DefEntityValue <$> entityvalue) `onFail` -- ( do eid <- externalid -- ndd <- maybe ndatadecl -- return (DefExternalID eid ndd)) -- --pedef :: HParser PEDef --pedef =--- ( entityvalue >>= return . PEDefEntityValue) `onFail`--- ( externalid >>= return . PEDefExternalID)+-- (PEDefEntityValue <$> entityvalue) `onFail`+-- (PEDefExternalID <$> externalid) externalid :: HParser ExternalID externalid = ( do word "SYSTEM"- s <- systemliteral- return (SYSTEM s)) `onFail`+ SYSTEM <$> systemliteral+ ) `onFail` ( do word "PUBLIC" p <- pubidliteral- s <- (systemliteral `onFail` return (SystemLiteral ""))+ s <- systemliteral `onFail` return (SystemLiteral "") return (PUBLIC p s)) --ndatadecl :: HParser NDataDecl@@ -667,9 +667,9 @@ encodingdecl :: HParser EncodingDecl encodingdecl = do- (word "encoding" `onFail` word "ENCODING")+ word "encoding" `onFail` word "ENCODING" tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"- f <- bracket (tok TokQuote) (tok TokQuote) freetext+ f <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (EncodingDecl f) --notationdecl :: HParser NotationDecl@@ -689,18 +689,18 @@ --entityvalue :: HParser EntityValue --entityvalue = do--- evs <- bracket (tok TokQuote) (tok TokQuote) (many ev)+-- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many ev) -- return (EntityValue evs) --ev :: HParser EV --ev =--- ( freetext >>= return . EVString) `onFail`+-- (EVString <$> freetext) `onFail` -- -- PEREF(EVPERef,ev) `onFail`--- ( reference >>= return . EVRef)+-- (EVRef <$> reference) attvalue :: HParser AttValue attvalue =- ( do avs <- bracket (tok TokQuote) (tok TokQuote)+ ( do avs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) ) `onFail` ( do v <- nmtoken@@ -715,14 +715,13 @@ systemliteral :: HParser SystemLiteral systemliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext- return (SystemLiteral s) -- note: need to fold &...; escapes+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext+ return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext- return (PubidLiteral s) -- note: need to fold &...; escapes+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext+ return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData-chardata = freetext -- >>= return . CharData-+chardata = freetext -- <&> CharData
src/Text/XML/HaXml/Html/Pretty.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | This is a separate pretty-printer for HTML documents, recognising -- some of the differences between HTML and true XML. @@ -8,7 +9,12 @@ , content ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding (maybe,either,(<>))+#else import Prelude hiding (maybe,either)+#endif+ import Data.Maybe hiding (maybe) import Data.List (intersperse) import Data.Char (isSpace)@@ -58,7 +64,7 @@ misc (PI (n,s)) = text "<?" <> text n <+> text s <+> text "?>" sddecl sd | sd = text "standalone='yes'" | otherwise = text "standalone='no'"-doctypedecl (DTD n eid ds) = if null ds then +doctypedecl (DTD n eid ds) = if null ds then hd <> text ">" else hd <+> text " [" $$ vcat (map markupdecl ds) $$ text "]>"@@ -144,39 +150,39 @@ content (CRef r _) = reference r content (CMisc m _) = misc m -elementdecl :: ElementDecl -> Doc-contentspec :: ContentSpec -> Doc-cp :: CP -> Doc-modifier :: Modifier -> Doc-mixed :: Mixed -> Doc-attlistdecl :: AttListDecl -> Doc-attdef :: AttDef -> Doc-atttype :: AttType -> Doc-tokenizedtype :: TokenizedType -> Doc-enumeratedtype :: EnumeratedType -> Doc-notationtype :: [String] -> Doc-enumeration :: [String] -> Doc-defaultdecl :: DefaultDecl -> Doc-reference :: Reference -> Doc-entityref :: String -> Doc-charref :: (Show a) => a -> Doc-entitydecl :: EntityDecl -> Doc-gedecl :: GEDecl -> Doc-pedecl :: PEDecl -> Doc-entitydef :: EntityDef -> Doc-pedef :: PEDef -> Doc-externalid :: ExternalID -> Doc-ndatadecl :: NDataDecl -> Doc-notationdecl :: NotationDecl -> Doc-publicid :: PublicID -> Doc-encodingdecl :: EncodingDecl -> Doc-nmtoken :: String -> Doc-attvalue :: AttValue -> Doc-entityvalue :: EntityValue -> Doc-ev :: EV -> Doc-pubidliteral :: PubidLiteral -> Doc-systemliteral :: SystemLiteral -> Doc-chardata :: [Char] -> Doc+elementdecl :: ElementDecl -> Doc+contentspec :: ContentSpec -> Doc+cp :: CP -> Doc+modifier :: Modifier -> Doc+mixed :: Mixed -> Doc+attlistdecl :: AttListDecl -> Doc+attdef :: AttDef -> Doc+atttype :: AttType -> Doc+tokenizedtype :: TokenizedType -> Doc+enumeratedtype :: EnumeratedType -> Doc+notationtype :: [String] -> Doc+enumeration :: [String] -> Doc+defaultdecl :: DefaultDecl -> Doc+reference :: Reference -> Doc+entityref :: String -> Doc+charref :: (Show a) => a -> Doc+entitydecl :: EntityDecl -> Doc+gedecl :: GEDecl -> Doc+pedecl :: PEDecl -> Doc+entitydef :: EntityDef -> Doc+pedef :: PEDef -> Doc+externalid :: ExternalID -> Doc+ndatadecl :: NDataDecl -> Doc+notationdecl :: NotationDecl -> Doc+publicid :: PublicID -> Doc+encodingdecl :: EncodingDecl -> Doc+nmtoken :: String -> Doc+attvalue :: AttValue -> Doc+entityvalue :: EntityValue -> Doc+ev :: EV -> Doc+pubidliteral :: PubidLiteral -> Doc+systemliteral :: SystemLiteral -> Doc+chardata :: [Char] -> Doc elementdecl (ElementDecl n cs) = text "<!ELEMENT" <+> qname n <+>
src/Text/XML/HaXml/Lex.hs view
@@ -38,38 +38,38 @@ -- | The basic token type. data TokenT =- TokCommentOpen -- ^ \<!--- | TokCommentClose -- ^ -->- | TokPIOpen -- ^ \<?- | TokPIClose -- ^ ?>- | TokSectionOpen -- ^ \<![- | TokSectionClose -- ^ ]]>- | TokSection Section -- ^ CDATA INCLUDE IGNORE etc- | TokSpecialOpen -- ^ \<!- | TokSpecial Special -- ^ DOCTYPE ELEMENT ATTLIST etc- | TokEndOpen -- ^ \<\/- | TokEndClose -- ^ \/>- | TokAnyOpen -- ^ \<- | TokAnyClose -- ^ >- | TokSqOpen -- ^ \[- | TokSqClose -- ^ \]- | TokEqual -- ^ =- | TokQuery -- ^ ?- | TokStar -- ^ \*- | TokPlus -- ^ +- | TokAmp -- ^ &- | TokSemi -- ^ ;- | TokHash -- ^ #- | TokBraOpen -- ^ (- | TokBraClose -- ^ )- | TokPipe -- ^ |- | TokPercent -- ^ %- | TokComma -- ^ ,- | TokQuote -- ^ \'\' or \"\"- | TokName String -- ^ begins with letter, no spaces- | TokFreeText String -- ^ any character data- | TokNull -- ^ fake token- | TokError String -- ^ lexical error+ TokCommentOpen -- ^ \<!--+ | TokCommentClose -- ^ -->+ | TokPIOpen -- ^ \<?+ | TokPIClose -- ^ ?>+ | TokSectionOpen -- ^ \<![+ | TokSectionClose -- ^ ]]>+ | TokSection Section -- ^ CDATA INCLUDE IGNORE etc+ | TokSpecialOpen -- ^ \<!+ | TokSpecial Special -- ^ DOCTYPE ELEMENT ATTLIST etc+ | TokEndOpen -- ^ \<\/+ | TokEndClose -- ^ \/>+ | TokAnyOpen -- ^ \<+ | TokAnyClose -- ^ >+ | TokSqOpen -- ^ \[+ | TokSqClose -- ^ \]+ | TokEqual -- ^ =+ | TokQuery -- ^ ?+ | TokStar -- ^ \*+ | TokPlus -- ^ ++ | TokAmp -- ^ &+ | TokSemi -- ^ ;+ | TokHash -- ^ #+ | TokBraOpen -- ^ (+ | TokBraClose -- ^ )+ | TokPipe -- ^ |+ | TokPercent -- ^ %+ | TokComma -- ^ ,+ | TokQuote -- ^ \'\' or \"\"+ | TokName String -- ^ begins with letter, no spaces+ | TokFreeText String -- ^ any character data+ | TokNull -- ^ fake token+ | TokError String -- ^ lexical error deriving (Eq) data Special =@@ -86,38 +86,38 @@ deriving (Eq,Show) instance Show TokenT where- showsPrec _p TokCommentOpen = showString "<!--"- showsPrec _p TokCommentClose = showString "-->"- showsPrec _p TokPIOpen = showString "<?"- showsPrec _p TokPIClose = showString "?>"- showsPrec _p TokSectionOpen = showString "<!["- showsPrec _p TokSectionClose = showString "]]>"- showsPrec p (TokSection s) = showsPrec p s- showsPrec _p TokSpecialOpen = showString "<!"- showsPrec p (TokSpecial s) = showsPrec p s- showsPrec _p TokEndOpen = showString "</"- showsPrec _p TokEndClose = showString "/>"- showsPrec _p TokAnyOpen = showString "<"- showsPrec _p TokAnyClose = showString ">"- showsPrec _p TokSqOpen = showString "["- showsPrec _p TokSqClose = showString "]"- showsPrec _p TokEqual = showString "="- showsPrec _p TokQuery = showString "?"- showsPrec _p TokStar = showString "*"- showsPrec _p TokPlus = showString "+"- showsPrec _p TokAmp = showString "&"- showsPrec _p TokSemi = showString ";"- showsPrec _p TokHash = showString "#"- showsPrec _p TokBraOpen = showString "("- showsPrec _p TokBraClose = showString ")"- showsPrec _p TokPipe = showString "|"- showsPrec _p TokPercent = showString "%"- showsPrec _p TokComma = showString ","- showsPrec _p TokQuote = showString "' or \""- showsPrec _p (TokName s) = showString s- showsPrec _p (TokFreeText s) = showString s- showsPrec _p TokNull = showString "(null)"- showsPrec _p (TokError s) = showString s+ showsPrec _p TokCommentOpen = showString "<!--"+ showsPrec _p TokCommentClose = showString "-->"+ showsPrec _p TokPIOpen = showString "<?"+ showsPrec _p TokPIClose = showString "?>"+ showsPrec _p TokSectionOpen = showString "<!["+ showsPrec _p TokSectionClose = showString "]]>"+ showsPrec p (TokSection s) = showsPrec p s+ showsPrec _p TokSpecialOpen = showString "<!"+ showsPrec p (TokSpecial s) = showsPrec p s+ showsPrec _p TokEndOpen = showString "</"+ showsPrec _p TokEndClose = showString "/>"+ showsPrec _p TokAnyOpen = showString "<"+ showsPrec _p TokAnyClose = showString ">"+ showsPrec _p TokSqOpen = showString "["+ showsPrec _p TokSqClose = showString "]"+ showsPrec _p TokEqual = showString "="+ showsPrec _p TokQuery = showString "?"+ showsPrec _p TokStar = showString "*"+ showsPrec _p TokPlus = showString "+"+ showsPrec _p TokAmp = showString "&"+ showsPrec _p TokSemi = showString ";"+ showsPrec _p TokHash = showString "#"+ showsPrec _p TokBraOpen = showString "("+ showsPrec _p TokBraClose = showString ")"+ showsPrec _p TokPipe = showString "|"+ showsPrec _p TokPercent = showString "%"+ showsPrec _p TokComma = showString ","+ showsPrec _p TokQuote = showString "' or \""+ showsPrec _p (TokName s) = showString s+ showsPrec _p (TokFreeText s) = showString s+ showsPrec _p TokNull = showString "(null)"+ showsPrec _p (TokError s) = showString s --trim, revtrim :: String -> String --trim = f . f where f = reverse . dropWhile isSpace@@ -159,6 +159,10 @@ | close `prefixes` (s:ss) = emit (TokFreeText (reverse acc)) pos: emit tok p: skip (length close-1) (addcol 1 p) ss k+ | tok==TokSemi && length acc >= 8 -- special case for repairing broken &+ = emit (TokFreeText "amp") pos:+ emit tok pos:+ k (addcol 1 pos) (reverse acc++s:ss) | isSpace s = textUntil close tok (s:acc) pos (white s p) ss k | otherwise = textUntil close tok (s:acc) pos (addcol 1 p) ss k @@ -239,10 +243,12 @@ | "![" `prefixes` ss = emit TokSectionOpen p: skip 3 p s (xmlSection w) | "!" `prefixes` ss = emit TokSpecialOpen p: skip 2 p s (xmlSpecial (InTag "<!...>":w))- | "/" `prefixes` ss = emit TokEndOpen p: - skip 2 p s (xmlTag (InTag "</...>":tail w))+ | "/" `prefixes` ss = emit TokEndOpen p:+ skip 2 p s (xmlTag (InTag "</...>":tale w)) | otherwise = emit TokAnyOpen p: skip 1 p s (xmlTag (InTag "<...>":NotInTag:w))+ where tale [] = [NotInTag] -- cope with non-well-formed input+ tale xs = tail xs xmlAny (_:_:w) p s@('/':ss) | ">" `prefixes` ss = emit TokEndClose p: skip 2 p s (xmlAny w) xmlAny w p ('&':ss) = emit TokAmp p: textUntil ";" TokSemi "" p@@ -276,7 +282,7 @@ where p1 = addcol 1 p xmlAny w p s | isSpace (head s) = blank xmlAny w p s- | isAlphaNum (head s) || (head s)`elem`":_"+ | isAlphaNum (head s) || head s`elem`":_" = xmlName p s "some kind of name" (blank xmlAny w) | otherwise = lexerror ("unrecognised token: "++take 4 s) p @@ -295,7 +301,7 @@ let p0 = addcol n p in textUntil "]]>" TokSectionClose "" p0 p0 (drop n s) (blank xmlAny w) k w p s n =- skip n p s (xmlAny ({-InTag "<![section[ ... ]]>": -}w))+ skip n p s (xmlAny {-InTag "<![section[ ... ]]>": -}w) xmlSpecial w p s | "DOCTYPE" `prefixes` s = emit (TokSpecial DOCTYPEx) p: k 7@@ -310,7 +316,7 @@ xmlName :: Posn -> [Char] -> [Char] -> (Posn->[Char]->[Token]) -> [Token] xmlName p (s:ss) cxt k- | isAlphaNum s || s==':' || s=='_' = gatherName (s:[]) p (addcol 1 p) ss k+ | isAlphaNum s || s==':' || s=='_' = gatherName [s] p (addcol 1 p) ss k | otherwise = lexerror ("expected a "++cxt++", but got char "++show s) p where gatherName acc pos p [] k =@@ -326,7 +332,7 @@ xmlContent acc _w _pos p [] = if all isSpace acc then [] else lexerror "unexpected EOF between tags" p xmlContent acc w pos p (s:ss)- | elem s "<&" = {- if all isSpace acc then xmlAny w p (s:ss) else -}+ | s `elem` "<&" = {- if all isSpace acc then xmlAny w p (s:ss) else -} emit (TokFreeText (reverse acc)) pos: xmlAny w p (s:ss) | isSpace s = xmlContent (s:acc) w pos (white s p) ss | otherwise = xmlContent (s:acc) w pos (addcol 1 p) ss
src/Text/XML/HaXml/Namespaces.hs view
@@ -16,6 +16,7 @@ import Prelude hiding (lookup) import Text.XML.HaXml.Types import Data.Map as Map (Map, insert, lookup, empty)+import Data.Maybe (fromMaybe) import Data.List (isPrefixOf) -- | The null Namespace (no prefix, no URI).@@ -57,13 +58,13 @@ qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName qualify def env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in- QN (maybe nullNamespace{nsPrefix=pre} id+ QN (fromMaybe nullNamespace {nsPrefix=pre} (Map.lookup pre env)) nm | Just d <- def = QN d n | otherwise = N n qualify _ env qn@(QN ns n)- | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n+ | null (nsURI ns) = QN (fromMaybe ns (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | 'deQualify' has the same signature as 'qualify', but ignores the@@ -83,13 +84,13 @@ qualifyExceptLocal (Just def) env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in if nsPrefix def == pre then N nm- else QN (maybe nullNamespace{nsPrefix=pre} id+ else QN (fromMaybe nullNamespace{nsPrefix=pre} (Map.lookup pre env)) nm | otherwise = N n qualifyExceptLocal (Just def) env qn@(QN ns n) | def==ns = N n- | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n+ | null (nsURI ns) = QN (fromMaybe ns (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | The initial Namespace environment. It always has bindings for the@@ -100,7 +101,7 @@ ,nsURI="http://www.w3.org/2000/xmlns/"} $ Map.insert "xml" Namespace{nsPrefix="xml" ,nsURI="http://www.w3.org/XML/1998/namespace"}- $ Map.empty+ Map.empty -- | Add a fresh Namespace into the Namespace environment. It is not -- permitted to rebind the prefixes 'xml' or 'xmlns', but that is not@@ -130,7 +131,7 @@ where qualifyInDTD = qualify Nothing initNamespaceEnv walkProlog (Prolog xml misc0 mDTD misc1) =- Prolog xml misc0 (maybe Nothing (Just . walkDTD) mDTD) misc1+ Prolog xml misc0 (fmap walkDTD mDTD) misc1 walkDTD (DTD qn ext mds) = DTD (qualifyInDTD qn) ext (map walkMD mds) -- walkMD (Element ed) = Element (walkED ed)@@ -158,18 +159,20 @@ Elem (qualify def' env' qn) (map (\ (a,v)-> (qualify Nothing env' a, v)) attrs) (map (walkContent def' env') conts)- where def' = foldr const def -- like "maybe def head", but for lists- (map defNamespace (matching (=="xmlns") attrs))- env' = foldr augmentNamespaceEnv env- (map mkNamespace- (matching ("xmlns:"`isPrefixOf`) attrs))+ -- like "maybe def head", but for lists+ where def' = foldr (const . defNamespace) def+ (matching (=="xmlns") attrs)+ env' = foldr (augmentNamespaceEnv . mkNamespace) env+ (matching ("xmlns:"`isPrefixOf`) attrs) defNamespace :: Attribute -> Maybe Namespace defNamespace (_ {-N "xmlns"-}, atv) | null (show atv) = Nothing | otherwise = Just nullNamespace{nsURI=show atv} mkNamespace :: Attribute -> Namespace- mkNamespace (N n, atv) = let (_,':':nm) = span (/=':') n in + mkNamespace (N n, atv) = let (_,':':nm) = span (/=':') n in Namespace{nsPrefix=nm,nsURI=show atv}+ mkNamespace (q@(QN (Namespace{ nsURI="" }) n), atv) =+ Namespace{nsPrefix=n,nsURI=show atv} matching :: (String->Bool) -> [Attribute] -> [Attribute] matching p = filter (p . printableName . fst) --
src/Text/XML/HaXml/OneOfN.hs view
@@ -18,11 +18,11 @@ => XmlContent (OneOf1 a) where parseContents =- (choice OneOf1- $ fail "OneOf1")+ choice OneOf1+ $ fail "OneOf1" toContents (OneOf1 x) = toContents x -foldOneOf1 :: (a->z) -> +foldOneOf1 :: (a->z) -> OneOf1 a -> z foldOneOf1 a (OneOf1 z) = a z@@ -46,12 +46,12 @@ => XmlContent (OneOf2 a b) where parseContents =- (choice OneOf2 $ choice TwoOf2- $ fail "OneOf2")+ choice OneOf2 $ choice TwoOf2+ $ fail "OneOf2" toContents (OneOf2 x) = toContents x toContents (TwoOf2 x) = toContents x -foldOneOf2 :: (a->z) -> (b->z) -> +foldOneOf2 :: (a->z) -> (b->z) -> OneOf2 a b -> z foldOneOf2 a b (OneOf2 z) = a z@@ -70,13 +70,13 @@ => XmlContent (OneOf3 a b c) where parseContents =- (choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3- $ fail "OneOf3")+ choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3+ $ fail "OneOf3" toContents (OneOf3 x) = toContents x toContents (TwoOf3 x) = toContents x toContents (ThreeOf3 x) = toContents x -foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> +foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> OneOf3 a b c -> z foldOneOf3 a b c (OneOf3 z) = a z@@ -96,14 +96,14 @@ => XmlContent (OneOf4 a b c d) where parseContents =- (choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4- $ fail "OneOf4")+ choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4+ $ fail "OneOf4" toContents (OneOf4 x) = toContents x toContents (TwoOf4 x) = toContents x toContents (ThreeOf4 x) = toContents x toContents (FourOf4 x) = toContents x -foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> +foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> OneOf4 a b c d -> z foldOneOf4 a b c d (OneOf4 z) = a z@@ -124,16 +124,16 @@ => XmlContent (OneOf5 a b c d e) where parseContents =- (choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5+ choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5 $ choice FiveOf5- $ fail "OneOf5")+ $ fail "OneOf5" toContents (OneOf5 x) = toContents x toContents (TwoOf5 x) = toContents x toContents (ThreeOf5 x) = toContents x toContents (FourOf5 x) = toContents x toContents (FiveOf5 x) = toContents x -foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> +foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> OneOf5 a b c d e -> z foldOneOf5 a b c d e (OneOf5 z) = a z@@ -157,9 +157,9 @@ => XmlContent (OneOf6 a b c d e f) where parseContents =- (choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6+ choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6 $ choice FiveOf6 $ choice SixOf6- $ fail "OneOf6")+ $ fail "OneOf6" toContents (OneOf6 x) = toContents x toContents (TwoOf6 x) = toContents x toContents (ThreeOf6 x) = toContents x@@ -167,7 +167,7 @@ toContents (FiveOf6 x) = toContents x toContents (SixOf6 x) = toContents x -foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> +foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> OneOf6 a b c d e f -> z foldOneOf6 a b c d e f (OneOf6 z) = a z@@ -193,9 +193,9 @@ => XmlContent (OneOf7 a b c d e f g) where parseContents =- (choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7+ choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7 $ choice FiveOf7 $ choice SixOf7 $ choice SevenOf7- $ fail "OneOf7")+ $ fail "OneOf7" toContents (OneOf7 x) = toContents x toContents (TwoOf7 x) = toContents x toContents (ThreeOf7 x) = toContents x@@ -204,8 +204,8 @@ toContents (SixOf7 x) = toContents x toContents (SevenOf7 x) = toContents x -foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> +foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> OneOf7 a b c d e f g -> z foldOneOf7 a b c d e f g (OneOf7 z) = a z@@ -232,9 +232,9 @@ => XmlContent (OneOf8 a b c d e f g h) where parseContents =- (choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8+ choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8 $ choice FiveOf8 $ choice SixOf8 $ choice SevenOf8 $ choice EightOf8- $ fail "OneOf8")+ $ fail "OneOf8" toContents (OneOf8 x) = toContents x toContents (TwoOf8 x) = toContents x toContents (ThreeOf8 x) = toContents x@@ -244,8 +244,8 @@ toContents (SevenOf8 x) = toContents x toContents (EightOf8 x) = toContents x -foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> +foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> OneOf8 a b c d e f g h -> z foldOneOf8 a b c d e f g h (OneOf8 z) = a z@@ -273,10 +273,10 @@ => XmlContent (OneOf9 a b c d e f g h i) where parseContents =- (choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9+ choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9 $ choice FiveOf9 $ choice SixOf9 $ choice SevenOf9 $ choice EightOf9 $ choice NineOf9- $ fail "OneOf9")+ $ fail "OneOf9" toContents (OneOf9 x) = toContents x toContents (TwoOf9 x) = toContents x toContents (ThreeOf9 x) = toContents x@@ -287,8 +287,8 @@ toContents (EightOf9 x) = toContents x toContents (NineOf9 x) = toContents x -foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> +foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> OneOf9 a b c d e f g h i -> z foldOneOf9 a b c d e f g h i (OneOf9 z) = a z@@ -317,10 +317,10 @@ => XmlContent (OneOf10 a b c d e f g h i j) where parseContents =- (choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10+ choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10 $ choice FiveOf10 $ choice SixOf10 $ choice SevenOf10 $ choice EightOf10 $ choice NineOf10 $ choice TenOf10- $ fail "OneOf10")+ $ fail "OneOf10" toContents (OneOf10 x) = toContents x toContents (TwoOf10 x) = toContents x toContents (ThreeOf10 x) = toContents x@@ -332,8 +332,8 @@ toContents (NineOf10 x) = toContents x toContents (TenOf10 x) = toContents x -foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> +foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> OneOf10 a b c d e f g h i j -> z foldOneOf10 a b c d e f g h i j (OneOf10 z) = a z@@ -366,11 +366,11 @@ => XmlContent (OneOf11 a b c d e f g h i j k) where parseContents =- (choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11+ choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11 $ choice FiveOf11 $ choice SixOf11 $ choice SevenOf11 $ choice EightOf11 $ choice NineOf11 $ choice TenOf11 $ choice ElevenOf11- $ fail "OneOf11")+ $ fail "OneOf11" toContents (OneOf11 x) = toContents x toContents (TwoOf11 x) = toContents x toContents (ThreeOf11 x) = toContents x@@ -383,8 +383,8 @@ toContents (TenOf11 x) = toContents x toContents (ElevenOf11 x) = toContents x -foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> +foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> OneOf11 a b c d e f g h i j k -> z foldOneOf11 a b c d e f g h i j k (OneOf11 z) = a z@@ -418,11 +418,11 @@ => XmlContent (OneOf12 a b c d e f g h i j k l) where parseContents =- (choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12+ choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12 $ choice FiveOf12 $ choice SixOf12 $ choice SevenOf12 $ choice EightOf12 $ choice NineOf12 $ choice TenOf12 $ choice ElevenOf12 $ choice TwelveOf12- $ fail "OneOf12")+ $ fail "OneOf12" toContents (OneOf12 x) = toContents x toContents (TwoOf12 x) = toContents x toContents (ThreeOf12 x) = toContents x@@ -436,8 +436,8 @@ toContents (ElevenOf12 x) = toContents x toContents (TwelveOf12 x) = toContents x -foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> +foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> OneOf12 a b c d e f g h i j k l -> z foldOneOf12 a b c d e f g h i j k l (OneOf12 z) = a z@@ -472,11 +472,11 @@ => XmlContent (OneOf13 a b c d e f g h i j k l m) where parseContents =- (choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13+ choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13 $ choice FiveOf13 $ choice SixOf13 $ choice SevenOf13 $ choice EightOf13 $ choice NineOf13 $ choice TenOf13 $ choice ElevenOf13 $ choice TwelveOf13 $ choice ThirteenOf13- $ fail "OneOf13")+ $ fail "OneOf13" toContents (OneOf13 x) = toContents x toContents (TwoOf13 x) = toContents x toContents (ThreeOf13 x) = toContents x@@ -491,9 +491,9 @@ toContents (TwelveOf13 x) = toContents x toContents (ThirteenOf13 x) = toContents x -foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> +foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> OneOf13 a b c d e f g h i j k l m -> z foldOneOf13 a b c d e f g h i j k l m (OneOf13 z) = a z@@ -529,12 +529,12 @@ => XmlContent (OneOf14 a b c d e f g h i j k l m n) where parseContents =- (choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14+ choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14 $ choice FiveOf14 $ choice SixOf14 $ choice SevenOf14 $ choice EightOf14 $ choice NineOf14 $ choice TenOf14 $ choice ElevenOf14 $ choice TwelveOf14 $ choice ThirteenOf14 $ choice FourteenOf14- $ fail "OneOf14")+ $ fail "OneOf14" toContents (OneOf14 x) = toContents x toContents (TwoOf14 x) = toContents x toContents (ThreeOf14 x) = toContents x@@ -550,9 +550,9 @@ toContents (ThirteenOf14 x) = toContents x toContents (FourteenOf14 x) = toContents x -foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> +foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> OneOf14 a b c d e f g h i j k l m n -> z foldOneOf14 a b c d e f g h i j k l m n (OneOf14 z) = a z@@ -590,12 +590,12 @@ => XmlContent (OneOf15 a b c d e f g h i j k l m n o) where parseContents =- (choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15+ choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15 $ choice FiveOf15 $ choice SixOf15 $ choice SevenOf15 $ choice EightOf15 $ choice NineOf15 $ choice TenOf15 $ choice ElevenOf15 $ choice TwelveOf15 $ choice ThirteenOf15 $ choice FourteenOf15 $ choice FifteenOf15- $ fail "OneOf15")+ $ fail "OneOf15" toContents (OneOf15 x) = toContents x toContents (TwoOf15 x) = toContents x toContents (ThreeOf15 x) = toContents x@@ -612,9 +612,9 @@ toContents (FourteenOf15 x) = toContents x toContents (FifteenOf15 x) = toContents x -foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> +foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> OneOf15 a b c d e f g h i j k l m n o -> z foldOneOf15 a b c d e f g h i j k l m n o (OneOf15 z) = a z@@ -655,12 +655,12 @@ => XmlContent (OneOf16 a b c d e f g h i j k l m n o p) where parseContents =- (choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16+ choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16 $ choice FiveOf16 $ choice SixOf16 $ choice SevenOf16 $ choice EightOf16 $ choice NineOf16 $ choice TenOf16 $ choice ElevenOf16 $ choice TwelveOf16 $ choice ThirteenOf16 $ choice FourteenOf16 $ choice FifteenOf16 $ choice SixteenOf16- $ fail "OneOf16")+ $ fail "OneOf16" toContents (OneOf16 x) = toContents x toContents (TwoOf16 x) = toContents x toContents (ThreeOf16 x) = toContents x@@ -678,9 +678,9 @@ toContents (FifteenOf16 x) = toContents x toContents (SixteenOf16 x) = toContents x -foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> +foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> OneOf16 a b c d e f g h i j k l m n o p -> z foldOneOf16 a b c d e f g h i j k l m n o p (OneOf16 z) = a z@@ -722,13 +722,13 @@ => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q) where parseContents =- (choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17+ choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17 $ choice FiveOf17 $ choice SixOf17 $ choice SevenOf17 $ choice EightOf17 $ choice NineOf17 $ choice TenOf17 $ choice ElevenOf17 $ choice TwelveOf17 $ choice ThirteenOf17 $ choice FourteenOf17 $ choice FifteenOf17 $ choice SixteenOf17 $ choice SeventeenOf17- $ fail "OneOf17")+ $ fail "OneOf17" toContents (OneOf17 x) = toContents x toContents (TwoOf17 x) = toContents x toContents (ThreeOf17 x) = toContents x@@ -747,9 +747,9 @@ toContents (SixteenOf17 x) = toContents x toContents (SeventeenOf17 x) = toContents x -foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> +foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> OneOf17 a b c d e f g h i j k l m n o p q -> z foldOneOf17 a b c d e f g h i j k l m n o p q (OneOf17 z) = a z@@ -792,13 +792,13 @@ => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r) where parseContents =- (choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18+ choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18 $ choice FiveOf18 $ choice SixOf18 $ choice SevenOf18 $ choice EightOf18 $ choice NineOf18 $ choice TenOf18 $ choice ElevenOf18 $ choice TwelveOf18 $ choice ThirteenOf18 $ choice FourteenOf18 $ choice FifteenOf18 $ choice SixteenOf18 $ choice SeventeenOf18 $ choice EighteenOf18- $ fail "OneOf18")+ $ fail "OneOf18" toContents (OneOf18 x) = toContents x toContents (TwoOf18 x) = toContents x toContents (ThreeOf18 x) = toContents x@@ -818,9 +818,9 @@ toContents (SeventeenOf18 x) = toContents x toContents (EighteenOf18 x) = toContents x -foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> +foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> OneOf18 a b c d e f g h i j k l m n o p q r -> z foldOneOf18 a b c d e f g h i j k l m n o p q r (OneOf18 z) = a z@@ -865,13 +865,13 @@ => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s) where parseContents =- (choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19+ choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19 $ choice FiveOf19 $ choice SixOf19 $ choice SevenOf19 $ choice EightOf19 $ choice NineOf19 $ choice TenOf19 $ choice ElevenOf19 $ choice TwelveOf19 $ choice ThirteenOf19 $ choice FourteenOf19 $ choice FifteenOf19 $ choice SixteenOf19 $ choice SeventeenOf19 $ choice EighteenOf19 $ choice NineteenOf19- $ fail "OneOf19")+ $ fail "OneOf19" toContents (OneOf19 x) = toContents x toContents (TwoOf19 x) = toContents x toContents (ThreeOf19 x) = toContents x@@ -892,10 +892,10 @@ toContents (EighteenOf19 x) = toContents x toContents (NineteenOf19 x) = toContents x -foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> - (s->z) -> +foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) ->+ (s->z) -> OneOf19 a b c d e f g h i j k l m n o p q r s -> z foldOneOf19 a b c d e f g h i j k l m n o p q r s (OneOf19 z) = a z@@ -941,14 +941,14 @@ => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t) where parseContents =- (choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20+ choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20 $ choice FiveOf20 $ choice SixOf20 $ choice SevenOf20 $ choice EightOf20 $ choice NineOf20 $ choice TenOf20 $ choice ElevenOf20 $ choice TwelveOf20 $ choice ThirteenOf20 $ choice FourteenOf20 $ choice FifteenOf20 $ choice SixteenOf20 $ choice SeventeenOf20 $ choice EighteenOf20 $ choice NineteenOf20 $ choice TwentyOf20- $ fail "OneOf20")+ $ fail "OneOf20" toContents (OneOf20 x) = toContents x toContents (TwoOf20 x) = toContents x toContents (ThreeOf20 x) = toContents x@@ -970,10 +970,10 @@ toContents (NineteenOf20 x) = toContents x toContents (TwentyOf20 x) = toContents x -foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> - (s->z) -> (t->z) -> +foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) ->+ (s->z) -> (t->z) -> OneOf20 a b c d e f g h i j k l m n o p q r s t -> z foldOneOf20 a b c d e f g h i j k l m n o p q r s
src/Text/XML/HaXml/Parse.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-} -- | A non-validating XML parser. For the input grammar, see -- <http://www.w3.org/TR/REC-xml>. module Text.XML.HaXml.Parse@@ -32,7 +32,7 @@ import Prelude hiding (either,maybe,sequence) import qualified Prelude (either) import Data.Maybe hiding (maybe)-import Data.List (intersperse) -- debugging only+import Data.List (intercalate) import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex)@@ -105,7 +105,7 @@ dtdParse' name = fst3 . runParser justDTD emptySTs . xmlLex name toEOF :: XParser a -> XParser a-toEOF = id -- there are other possible implementations...+toEOF = id -- there are other possible implementations... -- | To parse a partial document, e.g. from an XML-based stream protocol, -- where you may later want to get more document elements from the same@@ -155,13 +155,6 @@ ---- Auxiliary Parsing Functions ---- --- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad-myBracket :: PolyParse p => p bra -> p ket -> p a -> p a-myBracket open close p = do- do { open `adjustErr` ("Missing opening bracket:\n\t"++)- ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))- }- -- | XParser is just a specialisation of the PolyState parser. type XParser a = Parser SymTabs (Posn,TokenT) a @@ -179,7 +172,20 @@ -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName-qname = fmap N name+qname = do+ (p,tok) <- next+ case tok of+ TokName s -> case split ':' s of+ [one] -> return $ N s+ [ns,elem_name] -> return $ QN (Namespace ns "") elem_name+ _ -> report fail "a name" p tok+ TokError _ -> report failBad "a name" p tok+ _ -> report fail "a name" p tok+ where+ split :: Char -> String -> [String]+ split c xs = case break (==c) xs of+ (ls, "") -> [ls]+ (ls, x:rs) -> ls : split c rs -- | Return just a name, e.g. element name, attribute name. name :: XParser Name@@ -199,13 +205,13 @@ maybe :: XParser a -> XParser (Maybe a) maybe p =- ( p >>= return . Just) `onFail`- ( return Nothing)+ ( Just <$> p) `onFail`+ return Nothing either :: XParser a -> XParser b -> XParser (Either a b) either p q =- ( p >>= return . Left) `onFail`- ( q >>= return . Right)+ ( Left <$> p) `onFail`+ ( Right <$> q) word :: String -> XParser () word s = do { x <- next@@ -223,7 +229,7 @@ } nmtoken :: XParser NmToken-nmtoken = (string `onFail` freetext)+nmtoken = string `onFail` freetext failP, failBadP :: String -> XParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) }@@ -307,7 +313,7 @@ -- | Return an XML comment. comment :: XParser Comment comment = do- myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext+ bracket (tok TokCommentOpen) (tok TokCommentClose) freetext -- tok TokCommentOpen -- commit $ do -- c <- freetext@@ -327,7 +333,7 @@ cdsect :: XParser CDSect cdsect = do tok TokSectionOpen- bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata+ bracket (tok (TokSection CDATAx)) (commit $ tok TokSectionClose) chardata prolog :: XParser Prolog prolog = do@@ -340,7 +346,7 @@ xmldecl :: XParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -356,14 +362,14 @@ versioninfo :: XParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual- bracket (tok TokQuote) (tok TokQuote) freetext+ bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: XParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] -- | Return a DOCTYPE decl, indicating a DTD.@@ -374,19 +380,19 @@ commit $ do n <- qname eid <- maybe externalid- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)+ es <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose) (many (peRef markupdecl))) blank (tok TokAnyClose) `onFail` failP "missing > in DOCTYPE decl"- return (DTD n eid (case es of { Nothing -> []; Just e -> e }))+ return (DTD n eid (fromMaybe [] es)) -- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc markupdecl :: XParser MarkupDecl markupdecl =- oneOf' [ ("ELEMENT", elementdecl >>= return . Element)- , ("ATTLIST", attlistdecl >>= return . AttList)- , ("ENTITY", entitydecl >>= return . Entity)- , ("NOTATION", notationdecl >>= return . Notation)- , ("misc", misc >>= return . MarkupMisc)+ oneOf' [ ("ELEMENT", Element <$> elementdecl )+ , ("ATTLIST", AttList <$> attlistdecl )+ , ("ENTITY", Entity <$> entitydecl )+ , ("NOTATION", Notation <$> notationdecl)+ , ("misc", MarkupMisc <$> misc ) ] `adjustErrP` ("when looking for a markup decl,\n"++)@@ -400,15 +406,15 @@ extsubsetdecl :: XParser ExtSubsetDecl extsubsetdecl =- ( markupdecl >>= return . ExtMarkupDecl) `onFail`- ( conditionalsect >>= return . ExtConditionalSect)+ ( ExtMarkupDecl <$> markupdecl) `onFail`+ ( ExtConditionalSect <$> conditionalsect) sddecl :: XParser SDDecl sddecl = do- (word "standalone" `onFail` word "STANDALONE")+ word "standalone" `onFail` word "STANDALONE" commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl"- bracket (tok TokQuote) (tok TokQuote)+ bracket (tok TokQuote) (commit $ tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" )@@ -425,7 +431,7 @@ , do tok TokAnyClose cs <- many content p <- posn- m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname+ m <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname checkmatch p n m return (Elem n as cs)) ] `adjustErr` (("in element tag "++n++",\n")++)@@ -445,7 +451,7 @@ manyFinally content (do p <- posn m <- bracket (tok TokEndOpen)- (tok TokAnyClose) qname+ (commit $ tok TokAnyClose) qname checkmatch p n m) ) `adjustErrBad` (("in element tag "++printableName n++",\n")++) @@ -495,11 +501,11 @@ ; return (c' p) } where- content' = oneOf' [ ("element", element >>= return . CElem)- , ("chardata", chardata >>= return . CString False)- , ("reference", reference >>= return . CRef)- , ("CDATA", cdsect >>= return . CString True)- , ("misc", misc >>= return . CMisc)+ content' = oneOf' [ ("element", CElem <$> element )+ , ("chardata", CString False <$> chardata )+ , ("reference", CRef <$> reference)+ , ("CDATA", CString True <$> cdsect )+ , ("misc", CMisc <$> misc ) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")@@ -515,65 +521,65 @@ blank (tok TokAnyClose) `onFail` failBadP ("expected > terminating ELEMENT decl" ++"\n element name was "++show (printableName n)- ++"\n contentspec was "++(\ (ContentSpec p)-> show p) c)+ ++"\n contentspec was "++(\ (ContentSpec p)-> debugShowCP p) c) return (ElementDecl n c) contentspec :: XParser ContentSpec contentspec = oneOf' [ ("EMPTY", peRef (word "EMPTY") >> return EMPTY) , ("ANY", peRef (word "ANY") >> return ANY)- , ("mixed", peRef mixed >>= return . Mixed)- , ("simple", peRef cp >>= return . ContentSpec)+ , ("mixed", Mixed <$> peRef mixed)+ , ("simple", ContentSpec <$> peRef cp) ] -- `adjustErr` ("when looking for content spec,\n"++) -- `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)") choice :: XParser [CP] choice = do- myBracket (tok TokBraOpen `debug` "Trying choice")- (blank (tok TokBraClose `debug` "Succeeded with choice"))- (peRef cp `sepBy1` blank (tok TokPipe))+ bracket (tok TokBraOpen `debug` "Trying choice")+ (blank (tok TokBraClose `debug` "Succeeded with choice"))+ (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do- myBracket (tok TokBraOpen `debug` "Trying sequence")- (blank (tok TokBraClose `debug` "Succeeded with sequence"))- (peRef cp `sepBy1` blank (tok TokComma))+ bracket (tok TokBraOpen `debug` "Trying sequence")+ (blank (tok TokBraClose `debug` "Succeeded with sequence"))+ (peRef cp `sepBy1` blank (tok TokComma)) cp :: XParser CP-cp = oneOf [ ( do n <- qname- m <- modifier- let c = TagName n m- return c `debug` ("ContentSpec: name "++show c))- , ( do ss <- sequence- m <- modifier- let c = Seq ss m- return c `debug` ("ContentSpec: sequence "++show c))- , ( do cs <- choice- m <- modifier- let c = Choice cs m- return c `debug` ("ContentSpec: choice "++show c))+cp = oneOf [ do n <- qname+ m <- modifier+ let c = TagName n m+ return c `debug` ("ContentSpec: name "++debugShowCP c)+ , do ss <- sequence+ m <- modifier+ let c = Seq ss m+ return c `debug` ("ContentSpec: sequence "++debugShowCP c)+ , do cs <- choice+ m <- modifier+ let c = Choice cs m+ return c `debug` ("ContentSpec: choice "++debugShowCP c) ] `adjustErr` (++"\nwhen looking for a content particle") modifier :: XParser Modifier-modifier = oneOf [ ( tok TokStar >> return Star )- , ( tok TokQuery >> return Query )- , ( tok TokPlus >> return Plus )- , ( return None )+modifier = oneOf [ tok TokStar >> return Star+ , tok TokQuery >> return Query+ , tok TokPlus >> return Plus+ , return None ] -- just for debugging-instance Show CP where- show (TagName n m) = printableName n++show m- show (Choice cps m) = '(': concat (intersperse "|" (map show cps))- ++")"++show m- show (Seq cps m) = '(': concat (intersperse "," (map show cps))- ++")"++show m-instance Show Modifier where- show None = ""- show Query = "?"- show Star = "*"- show Plus = "+"+debugShowCP :: CP -> String+debugShowCP cp = case cp of+ TagName n m -> printableName n++debugShowModifier m+ Choice cps m -> '(': intercalate "|" (map debugShowCP cps)++")"++debugShowModifier m+ Seq cps m -> '(': intercalate "," (map debugShowCP cps)++")"++debugShowModifier m+debugShowModifier :: Modifier -> String+debugShowModifier modifier = case modifier of+ None -> ""+ Query -> "?"+ Star -> "*"+ Plus -> "+" ---- mixed :: XParser Mixed@@ -582,12 +588,12 @@ peRef (do tok TokHash word "PCDATA") commit $- oneOf [ ( do cs <- many (peRef (do tok TokPipe- peRef qname))- blank (tok TokBraClose >> tok TokStar)- return (PCDATAplus cs))- , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)- , ( blank (tok TokBraClose) >> return PCDATA)+ oneOf [ do cs <- many (peRef (do tok TokPipe+ peRef qname))+ blank (tok TokBraClose >> tok TokStar)+ return (PCDATAplus cs)+ , blank (tok TokBraClose >> tok TokStar) >> return PCDATA+ , blank (tok TokBraClose) >> return PCDATA ] `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n") @@ -612,21 +618,21 @@ atttype :: XParser AttType atttype = oneOf' [ ("CDATA", word "CDATA" >> return StringType)- , ("tokenized", tokenizedtype >>= return . TokenizedType)- , ("enumerated", enumeratedtype >>= return . EnumeratedType)+ , ("tokenized", TokenizedType <$> tokenizedtype)+ , ("enumerated", EnumeratedType <$> enumeratedtype) ] `adjustErr` ("looking for ATTTYPE,\n"++) -- `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated") tokenizedtype :: XParser TokenizedType tokenizedtype =- oneOf [ ( word "ID" >> return ID)- , ( word "IDREF" >> return IDREF)- , ( word "IDREFS" >> return IDREFS)- , ( word "ENTITY" >> return ENTITY)- , ( word "ENTITIES" >> return ENTITIES)- , ( word "NMTOKEN" >> return NMTOKEN)- , ( word "NMTOKENS" >> return NMTOKENS)+ oneOf [ word "ID" >> return ID+ , word "IDREF" >> return IDREF+ , word "IDREFS" >> return IDREFS+ , word "ENTITY" >> return ENTITY+ , word "ENTITIES" >> return ENTITIES+ , word "NMTOKEN" >> return NMTOKEN+ , word "NMTOKENS" >> return NMTOKENS ] `onFail` do { t <- next ; failP ("Expected one of"@@ -636,20 +642,20 @@ enumeratedtype :: XParser EnumeratedType enumeratedtype =- oneOf' [ ("NOTATION", notationtype >>= return . NotationType)- , ("enumerated", enumeration >>= return . Enumeration)+ oneOf' [ ("NOTATION", NotationType <$> notationtype)+ , ("enumerated", Enumeration <$> enumeration) ] `adjustErr` ("looking for an enumerated or NOTATION type,\n"++) notationtype :: XParser NotationType notationtype = do word "NOTATION"- bracket (tok TokBraOpen) (blank (tok TokBraClose))+ bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration =- bracket (tok TokBraOpen) (blank (tok TokBraClose))+ bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose) (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe))) defaultdecl :: XParser DefaultDecl@@ -716,7 +722,7 @@ -- | Return either a general entity reference, or a character reference. reference :: XParser Reference reference = do- myBracket (tok TokAmp) (tok TokSemi) (freetext >>= val)+ bracket (tok TokAmp) (tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i@@ -726,16 +732,16 @@ {- -- following is incorrect reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ ( RefChar <$> charref) `onFail`+ ( RefEntity <$> entityref) entityref :: XParser EntityRef entityref = do- bracket (tok TokAmp) (tok TokSemi) name+ bracket (tok TokAmp) (commit $ tok TokSemi) name charref :: XParser CharRef charref = do- bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)+ bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i@@ -744,12 +750,12 @@ pereference :: XParser PEReference pereference = do- myBracket (tok TokPercent) (tok TokSemi) nmtoken+ bracket (tok TokPercent) (tok TokSemi) nmtoken entitydecl :: XParser EntityDecl entitydecl =- ( gedecl >>= return . EntityGEDecl) `onFail`- ( pedecl >>= return . EntityPEDecl)+ ( EntityGEDecl <$> gedecl) `onFail`+ ( EntityPEDecl <$> pedecl) gedecl :: XParser GEDecl gedecl = do@@ -774,7 +780,7 @@ entitydef :: XParser EntityDef entitydef =- oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)+ oneOf' [ ("entityvalue", DefEntityValue <$> entityvalue) , ("external", do eid <- externalid ndd <- maybe ndatadecl return (DefExternalID eid ndd))@@ -782,32 +788,29 @@ pedef :: XParser PEDef pedef =- oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)- , ("externalid", externalid >>= return . PEDefExternalID)+ oneOf' [ ("entityvalue", PEDefEntityValue <$> entityvalue)+ , ("externalid", PEDefExternalID <$> externalid ) ] externalid :: XParser ExternalID externalid = oneOf' [ ("SYSTEM", do word "SYSTEM"- s <- systemliteral- return (SYSTEM s) )+ SYSTEM <$> systemliteral) , ("PUBLIC", do word "PUBLIC" p <- pubidliteral- s <- systemliteral- return (PUBLIC p s) )+ PUBLIC p <$> systemliteral) ] `adjustErr` ("looking for an external id,\n"++) ndatadecl :: XParser NDataDecl ndatadecl = do word "NDATA"- n <- name- return (NDATA n)+ NDATA <$> name textdecl :: XParser TextDecl textdecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" v <- maybe versioninfo e <- encodingdecl tok TokPIClose `onFail` failP "expected ?> terminating text decl"@@ -827,9 +830,9 @@ encodingdecl :: XParser EncodingDecl encodingdecl = do- (word "encoding" `onFail` word "ENCODING")+ word "encoding" `onFail` word "ENCODING" tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"- f <- bracket (tok TokQuote) (tok TokQuote) freetext+ f <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (EncodingDecl f) notationdecl :: XParser NotationDecl@@ -844,12 +847,11 @@ publicid :: XParser PublicID publicid = do word "PUBLIC"- p <- pubidliteral- return (PUBLICID p)+ PUBLICID <$> pubidliteral entityvalue :: XParser EntityValue entityvalue = do- -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))+ -- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (peRef ev)) tok TokQuote pn <- posn evs <- many ev@@ -857,38 +859,37 @@ -- quoted text must be rescanned for possible PERefs st <- stGet Prelude.either failBad (return . EntityValue) . fst3 $- (runParser (many ev) st+ runParser (many ev) st (reLexEntityValue (\s-> stringify (lookupPE s st)) pn- (flattenEV (EntityValue evs))))+ (flattenEV (EntityValue evs))) where stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev) stringify _ = Nothing ev :: XParser EV ev =- oneOf' [ ("string", (string`onFail`freetext) >>= return . EVString)- , ("reference", reference >>= return . EVRef)+ oneOf' [ ("string", EVString <$> (string`onFail`freetext))+ , ("reference", EVRef <$> reference) ] `adjustErr` ("looking for entity value,\n"++) attvalue :: XParser AttValue attvalue = do- avs <- bracket (tok TokQuote) (tok TokQuote)+ avs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (PubidLiteral s) -- note: freetext is too liberal here -- | Return parsed freetext (i.e. until the next markup) chardata :: XParser CharData chardata = freetext-
src/Text/XML/HaXml/ParseLazy.hs view
@@ -31,7 +31,7 @@ import Prelude hiding (either,maybe,sequence,catch) import qualified Prelude (either) import Data.Maybe hiding (maybe)-import Data.List (intersperse) -- debugging only+import Data.List (intercalate) import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex)@@ -109,7 +109,7 @@ dtdParse name = fst3 . runParser justDTD emptySTs . xmlLex name toEOF :: XParser a -> XParser a-toEOF = id -- there are other possible implementations...+toEOF = id -- there are other possible implementations... -- | To parse a partial document, e.g. from an XML-based stream protocol, -- where you may later want to get more document elements from the same@@ -159,14 +159,6 @@ ---- Auxiliary Parsing Functions ---- --- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad-myBracket :: PolyParse p => p bra -> p ket -> p a -> p a-myBracket open close p = do- do { open `adjustErr` ("Missing opening bracket:\n\t"++)- ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++))- }-- -- | XParser is just a specialisation of the PolyStateLazy parser. type XParser a = Parser SymTabs (Posn,TokenT) a @@ -184,7 +176,20 @@ -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName-qname = fmap N name+qname = do+ (p,tok) <- next+ case tok of+ TokName s -> case split ':' s of+ [one] -> return $ N s+ [ns,elem_name] -> return $ QN (Namespace ns "") elem_name+ _ -> report fail "a name" p tok+ TokError _ -> report failBad "a name" p tok+ _ -> report fail "a name" p tok+ where+ split :: Char -> String -> [String]+ split c xs = case break (==c) xs of+ (ls, "") -> [ls]+ (ls, x:rs) -> ls : split c rs -- | Return just a name, e.g. element name, attribute name. name :: XParser Name@@ -204,13 +209,13 @@ maybe :: XParser a -> XParser (Maybe a) maybe p =- ( p >>= return . Just) `onFail`- ( return Nothing)+ (Just <$> p) `onFail`+ return Nothing either :: XParser a -> XParser b -> XParser (Either a b) either p q =- ( p >>= return . Left) `onFail`- ( q >>= return . Right)+ (Left <$> p) `onFail`+ (Right <$> q) word :: String -> XParser () word s = do { x <- next@@ -228,7 +233,7 @@ } nmtoken :: XParser NmToken-nmtoken = (string `onFail` freetext)+nmtoken = string `onFail` freetext failP, failBadP :: String -> XParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) }@@ -310,14 +315,14 @@ -- return (Document p ge e ms) return Document `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++))- `apply` (fmap snd stGet)+ `apply` fmap snd stGet `apply` element `apply` many misc -- | Return an XML comment. comment :: XParser Comment comment = do- myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext+ bracket (tok TokCommentOpen) (tok TokCommentClose) freetext -- tok TokCommentOpen -- commit $ do -- c <- freetext@@ -337,7 +342,7 @@ cdsect :: XParser CDSect cdsect = do tok TokSectionOpen- bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata+ bracket (tok (TokSection CDATAx)) (commit $ tok TokSectionClose) chardata prolog :: XParser Prolog prolog = do@@ -350,7 +355,7 @@ xmldecl :: XParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -367,14 +372,14 @@ versioninfo :: XParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual- bracket (tok TokQuote) (tok TokQuote) freetext+ bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: XParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] -- | Return a DOCTYPE decl, indicating a DTD.@@ -385,19 +390,19 @@ commit $ do n <- qname eid <- maybe externalid- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)+ es <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose) (many (peRef markupdecl))) blank (tok TokAnyClose) `onFail` failP "missing > in DOCTYPE decl"- return (DTD n eid (case es of { Nothing -> []; Just e -> e }))+ return (DTD n eid (fromMaybe [] es)) -- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc markupdecl :: XParser MarkupDecl markupdecl =- oneOf' [ ("ELEMENT", elementdecl >>= return . Element)- , ("ATTLIST", attlistdecl >>= return . AttList)- , ("ENTITY", entitydecl >>= return . Entity)- , ("NOTATION", notationdecl >>= return . Notation)- , ("misc", misc >>= return . MarkupMisc)+ oneOf' [ ("ELEMENT", Element <$> elementdecl)+ , ("ATTLIST", AttList <$> attlistdecl)+ , ("ENTITY", Entity <$> entitydecl)+ , ("NOTATION", Notation <$> notationdecl)+ , ("misc", MarkupMisc <$> misc) ] `adjustErrP` ("when looking for a markup decl,\n"++)@@ -411,15 +416,15 @@ extsubsetdecl :: XParser ExtSubsetDecl extsubsetdecl =- ( markupdecl >>= return . ExtMarkupDecl) `onFail`- ( conditionalsect >>= return . ExtConditionalSect)+ (ExtMarkupDecl <$> markupdecl) `onFail`+ (ExtConditionalSect <$> conditionalsect) sddecl :: XParser SDDecl sddecl = do- (word "standalone" `onFail` word "STANDALONE")+ word "standalone" `onFail` word "STANDALONE" commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl"- bracket (tok TokQuote) (tok TokQuote)+ bracket (tok TokQuote) (commit $ tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" )@@ -436,7 +441,7 @@ , do tok TokAnyClose cs <- many content p <- posn- m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname+ m <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname checkmatch p n m return (Elem n as cs)) ] `adjustErr` (("in element tag "++n++",\n")++)@@ -455,7 +460,7 @@ commit $ manyFinally content (do p <- posn m <- bracket (tok TokEndOpen)- (tok TokAnyClose) qname+ (commit $ tok TokAnyClose) qname checkmatch p n m) ) `adjustErrBad` (("in element tag "++printableName n++",\n")++) @@ -505,11 +510,11 @@ ; return (c' p) } where- content' = oneOf' [ ("element", element >>= return . CElem)- , ("chardata", chardata >>= return . CString False)- , ("reference", reference >>= return . CRef)- , ("CDATA", cdsect >>= return . CString True)- , ("misc", misc >>= return . CMisc)+ content' = oneOf' [ ("element", CElem <$> element)+ , ("chardata", CString False <$> chardata)+ , ("reference", CRef <$> reference)+ , ("CDATA", CString True <$> cdsect)+ , ("misc", CMisc <$> misc) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")@@ -525,65 +530,65 @@ blank (tok TokAnyClose) `onFail` failBadP ("expected > terminating ELEMENT decl" ++"\n element name was "++show (printableName n)- ++"\n contentspec was "++(\ (ContentSpec p)-> show p) c)+ ++"\n contentspec was "++(\ (ContentSpec p)-> debugShowCP p) c) return (ElementDecl n c) contentspec :: XParser ContentSpec contentspec = oneOf' [ ("EMPTY", peRef (word "EMPTY") >> return EMPTY) , ("ANY", peRef (word "ANY") >> return ANY)- , ("mixed", peRef mixed >>= return . Mixed)- , ("simple", peRef cp >>= return . ContentSpec)+ , ("mixed", Mixed <$> peRef mixed)+ , ("simple", ContentSpec <$> peRef cp) ] -- `adjustErr` ("when looking for content spec,\n"++) -- `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)") choice :: XParser [CP] choice = do- myBracket (tok TokBraOpen `debug` "Trying choice")- (blank (tok TokBraClose `debug` "Succeeded with choice"))- (peRef cp `sepBy1` blank (tok TokPipe))+ bracket (tok TokBraOpen `debug` "Trying choice")+ (blank (tok TokBraClose `debug` "Succeeded with choice"))+ (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do- myBracket (tok TokBraOpen `debug` "Trying sequence")- (blank (tok TokBraClose `debug` "Succeeded with sequence"))- (peRef cp `sepBy1` blank (tok TokComma))+ bracket (tok TokBraOpen `debug` "Trying sequence")+ (blank (tok TokBraClose `debug` "Succeeded with sequence"))+ (peRef cp `sepBy1` blank (tok TokComma)) cp :: XParser CP-cp = oneOf [ ( do n <- qname- m <- modifier- let c = TagName n m- return c `debug` ("ContentSpec: name "++show c))- , ( do ss <- sequence- m <- modifier- let c = Seq ss m- return c `debug` ("ContentSpec: sequence "++show c))- , ( do cs <- choice- m <- modifier- let c = Choice cs m- return c `debug` ("ContentSpec: choice "++show c))+cp = oneOf [ do n <- qname+ m <- modifier+ let c = TagName n m+ return c `debug` ("ContentSpec: name "++debugShowCP c)+ , do ss <- sequence+ m <- modifier+ let c = Seq ss m+ return c `debug` ("ContentSpec: sequence "++debugShowCP c)+ , do cs <- choice+ m <- modifier+ let c = Choice cs m+ return c `debug` ("ContentSpec: choice "++debugShowCP c) ] `adjustErr` (++"\nwhen looking for a content particle") modifier :: XParser Modifier-modifier = oneOf [ ( tok TokStar >> return Star )- , ( tok TokQuery >> return Query )- , ( tok TokPlus >> return Plus )- , ( return None )+modifier = oneOf [ tok TokStar >> return Star+ , tok TokQuery >> return Query+ , tok TokPlus >> return Plus+ , return None ] -- just for debugging-instance Show CP where- show (TagName n m) = printableName n++show m- show (Choice cps m) = '(': concat (intersperse "|" (map show cps))- ++")"++show m- show (Seq cps m) = '(': concat (intersperse "," (map show cps))- ++")"++show m-instance Show Modifier where- show None = ""- show Query = "?"- show Star = "*"- show Plus = "+"+debugShowCP :: CP -> String+debugShowCP cp = case cp of+ TagName n m -> printableName n++debugShowModifier m+ Choice cps m -> '(': intercalate "|" (map debugShowCP cps)++")"++debugShowModifier m+ Seq cps m -> '(': intercalate "," (map debugShowCP cps)++")"++debugShowModifier m+debugShowModifier :: Modifier -> String+debugShowModifier modifier = case modifier of+ None -> ""+ Query -> "?"+ Star -> "*"+ Plus -> "+" ---- mixed :: XParser Mixed@@ -592,12 +597,12 @@ peRef (do tok TokHash word "PCDATA") commit $- oneOf [ ( do cs <- many (peRef (do tok TokPipe- peRef qname))- blank (tok TokBraClose >> tok TokStar)- return (PCDATAplus cs))- , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)- , ( blank (tok TokBraClose) >> return PCDATA)+ oneOf [ do cs <- many (peRef (do tok TokPipe+ peRef qname))+ blank (tok TokBraClose >> tok TokStar)+ return (PCDATAplus cs)+ , blank (tok TokBraClose >> tok TokStar) >> return PCDATA+ , blank (tok TokBraClose) >> return PCDATA ] `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n") @@ -622,21 +627,21 @@ atttype :: XParser AttType atttype = oneOf' [ ("CDATA", word "CDATA" >> return StringType)- , ("tokenized", tokenizedtype >>= return . TokenizedType)- , ("enumerated", enumeratedtype >>= return . EnumeratedType)+ , ("tokenized", TokenizedType <$> tokenizedtype)+ , ("enumerated", EnumeratedType <$> enumeratedtype) ] `adjustErr` ("looking for ATTTYPE,\n"++) -- `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated") tokenizedtype :: XParser TokenizedType tokenizedtype =- oneOf [ ( word "ID" >> return ID)- , ( word "IDREF" >> return IDREF)- , ( word "IDREFS" >> return IDREFS)- , ( word "ENTITY" >> return ENTITY)- , ( word "ENTITIES" >> return ENTITIES)- , ( word "NMTOKEN" >> return NMTOKEN)- , ( word "NMTOKENS" >> return NMTOKENS)+ oneOf [ word "ID" >> return ID+ , word "IDREF" >> return IDREF+ , word "IDREFS" >> return IDREFS+ , word "ENTITY" >> return ENTITY+ , word "ENTITIES" >> return ENTITIES+ , word "NMTOKEN" >> return NMTOKEN+ , word "NMTOKENS" >> return NMTOKENS ] `onFail` do { t <- next ; failP ("Expected one of"@@ -646,20 +651,20 @@ enumeratedtype :: XParser EnumeratedType enumeratedtype =- oneOf' [ ("NOTATION", notationtype >>= return . NotationType)- , ("enumerated", enumeration >>= return . Enumeration)+ oneOf' [ ("NOTATION", NotationType <$> notationtype)+ , ("enumerated", Enumeration <$> enumeration) ] `adjustErr` ("looking for an enumerated or NOTATION type,\n"++) notationtype :: XParser NotationType notationtype = do word "NOTATION"- bracket (tok TokBraOpen) (blank (tok TokBraClose))+ bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration =- bracket (tok TokBraOpen) (blank (tok TokBraClose))+ bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose) (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe))) defaultdecl :: XParser DefaultDecl@@ -726,7 +731,7 @@ -- | Return either a general entity reference, or a character reference. reference :: XParser Reference reference = do- bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)+ bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i@@ -736,16 +741,16 @@ {- -- following is incorrect reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ ( RefChar <$> charref) `onFail`+ ( RefEntity <$> entityref) entityref :: XParser EntityRef entityref = do- bracket (tok TokAmp) (tok TokSemi) name+ bracket (tok TokAmp) (commit $ tok TokSemi) name charref :: XParser CharRef charref = do- bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal)+ bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i@@ -754,12 +759,12 @@ pereference :: XParser PEReference pereference = do- myBracket (tok TokPercent) (tok TokSemi) nmtoken+ bracket (tok TokPercent) (tok TokSemi) nmtoken entitydecl :: XParser EntityDecl entitydecl =- ( gedecl >>= return . EntityGEDecl) `onFail`- ( pedecl >>= return . EntityPEDecl)+ ( EntityGEDecl <$> gedecl) `onFail`+ ( EntityPEDecl <$> pedecl) gedecl :: XParser GEDecl gedecl = do@@ -784,7 +789,7 @@ entitydef :: XParser EntityDef entitydef =- oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)+ oneOf' [ ("entityvalue", DefEntityValue <$> entityvalue) , ("external", do eid <- externalid ndd <- maybe ndatadecl return (DefExternalID eid ndd))@@ -792,32 +797,29 @@ pedef :: XParser PEDef pedef =- oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)- , ("externalid", externalid >>= return . PEDefExternalID)+ oneOf' [ ("entityvalue", PEDefEntityValue <$> entityvalue)+ , ("externalid", PEDefExternalID <$> externalid ) ] externalid :: XParser ExternalID externalid = oneOf' [ ("SYSTEM", do word "SYSTEM"- s <- systemliteral- return (SYSTEM s) )+ SYSTEM <$> systemliteral) , ("PUBLIC", do word "PUBLIC" p <- pubidliteral- s <- systemliteral- return (PUBLIC p s) )+ PUBLIC p <$> systemliteral) ] `adjustErr` ("looking for an external id,\n"++) ndatadecl :: XParser NDataDecl ndatadecl = do word "NDATA"- n <- name- return (NDATA n)+ NDATA <$> name textdecl :: XParser TextDecl textdecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" v <- maybe versioninfo e <- encodingdecl tok TokPIClose `onFail` failP "expected ?> terminating text decl"@@ -837,9 +839,9 @@ encodingdecl :: XParser EncodingDecl encodingdecl = do- (word "encoding" `onFail` word "ENCODING")+ word "encoding" `onFail` word "ENCODING" tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"- f <- bracket (tok TokQuote) (tok TokQuote) freetext+ f <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (EncodingDecl f) notationdecl :: XParser NotationDecl@@ -854,12 +856,11 @@ publicid :: XParser PublicID publicid = do word "PUBLIC"- p <- pubidliteral- return (PUBLICID p)+ PUBLICID <$> pubidliteral entityvalue :: XParser EntityValue entityvalue = do- -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev))+ -- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (peRef ev)) tok TokQuote pn <- posn evs <- many ev@@ -868,38 +869,37 @@ st <- stGet -- Prelude.either failBad (return . EntityValue) . fst3 $ return . EntityValue . fst3 $- (runParser (many ev) st+ runParser (many ev) st (reLexEntityValue (\s-> stringify (lookupPE s st)) pn- (flattenEV (EntityValue evs))))+ (flattenEV (EntityValue evs))) where stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev) stringify _ = Nothing ev :: XParser EV ev =- oneOf' [ ("string", (string`onFail`freetext) >>= return . EVString)- , ("reference", reference >>= return . EVRef)+ oneOf' [ ("string", EVString <$> (string`onFail`freetext))+ , ("reference", EVRef <$> reference) ] `adjustErr` ("looking for entity value,\n"++) attvalue :: XParser AttValue attvalue = do- avs <- bracket (tok TokQuote) (tok TokQuote)+ avs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do- s <- bracket (tok TokQuote) (tok TokQuote) freetext+ s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (PubidLiteral s) -- note: freetext is too liberal here -- | Return parsed freetext (i.e. until the next markup) chardata :: XParser CharData chardata = freetext-
src/Text/XML/HaXml/Pretty.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | This is a pretty-printer for turning the internal representation -- of generic structured XML documents into the Doc type (which can -- later be rendered using Text.PrettyPrint.HughesPJ.render).@@ -21,7 +22,12 @@ , cp ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding (maybe,either,(<>))+#else import Prelude hiding (maybe,either)+#endif+ import Data.Maybe hiding (maybe) import Data.List (intersperse) --import Char (isSpace)@@ -97,8 +103,13 @@ | all isText cs = text "<" <> qname n <+> fsep (map attribute as) <> text ">" <> hcat (map content cs) <> text "</" <> qname n <> text ">"- | otherwise = let (d,c) = carryelem e empty- in d <> c+ | otherwise = vcat [ text "<" <> qname n <> attributes as <> text ">"+ , nest 2 $ vcat (map content cs)+ , text "</" <> qname n <> text ">"+ ]++attributes [] = empty+attributes as@(_:_) = text " " <> fsep (map attribute as) isText :: Content t -> Bool isText (CString _ _ _) = True
src/Text/XML/HaXml/SAX.hs view
@@ -5,9 +5,9 @@ -- streams for communication. module Text.XML.HaXml.SAX- ( SaxElement(..)- , saxParse- ) where+ ( SaxElement(..)+ , saxParse+ ) where import Text.XML.HaXml.Types import Text.XML.HaXml.Parse@@ -15,34 +15,34 @@ import Text.ParserCombinators.Poly.State data SaxElement- = SaxDocTypeDecl DocTypeDecl- -- ^ A doctype declaration occured(\<!DOCTYPE\>)- | SaxProcessingInstruction ProcessingInstruction- -- ^ A processing instruction occured (\<??\>)- | SaxComment String -- ^ A comment occured (\<!-- --\>)- | SaxElementOpen Name [Attribute] -- ^ An element was opened (\<\>)- | SaxElementClose Name -- ^ An element was closed (\<\/\>)- | SaxElementTag Name [Attribute]- -- ^ An element without content occured (\<\/\>)- | SaxCharData CharData -- ^ Some string data occured- | SaxReference Reference -- ^ A reference occured+ = SaxDocTypeDecl DocTypeDecl+ -- ^ A doctype declaration occured(\<!DOCTYPE\>)+ | SaxProcessingInstruction ProcessingInstruction+ -- ^ A processing instruction occured (\<??\>)+ | SaxComment String -- ^ A comment occured (\<!-- --\>)+ | SaxElementOpen Name [Attribute] -- ^ An element was opened (\<\>)+ | SaxElementClose Name -- ^ An element was closed (\<\/\>)+ | SaxElementTag Name [Attribute]+ -- ^ An element without content occured (\<\/\>)+ | SaxCharData CharData -- ^ Some string data occured+ | SaxReference Reference -- ^ A reference occured -- | @saxParse file content@ takes a filename and the string content of that -- file and generates a stream of @SaxElement@s. If an error occurs, the -- parsing stops and a string is returned using the @Maybe@ type. saxParse :: String -- ^ The filename- -> String -- ^ The content of the file- -> ([SaxElement],Maybe String)- -- ^ A tuple of the parsed elements and @Nothing@, if no- -- error occured, or @Just@ @String@ if an error occured.+ -> String -- ^ The content of the file+ -> ([SaxElement],Maybe String)+ -- ^ A tuple of the parsed elements and @Nothing@, if no+ -- error occured, or @Just@ @String@ if an error occured. saxParse file cntnt = parseStream sax emptySTs (xmlLex file cntnt) parseStream :: Parser s t a -> s -> [t] -> ([a], Maybe String) parseStream _ _ [] = ([],Nothing) parseStream p state toks = case runParser p state toks of- (Left err, _, _) -> ([],Just err)- (Right res, nstate, rest) -> (res:moreres, err)+ (Left err, _, _) -> ([],Just err)+ (Right res, nstate, rest) -> (res:moreres, err) where (moreres,err) = parseStream p nstate rest sax :: XParser SaxElement@@ -54,40 +54,40 @@ , saxreference , saxchardata ]- `adjustErr` (++("\nLooking for a SAX event:\n"+ `adjustErr` (++("\nLooking for a SAX event:\n" ++" elem-open, elem-close, PI, comment, DTD, ref, or chardata")) saxelementopen :: XParser SaxElement saxelementopen = do- tok TokAnyOpen- (ElemTag (N n) as) <- elemtag -- no QN ever generated during parsing- (( do tok TokEndClose- return (SaxElementTag n as)) `onFail`- ( do tok TokAnyClose- return (SaxElementOpen n as))- `onFail` fail "missing > or /> in element tag")+ tok TokAnyOpen+ (ElemTag (N n) as) <- elemtag -- no QN ever generated during parsing+ ( do tok TokEndClose+ return (SaxElementTag n as)) `onFail`+ ( do tok TokAnyClose+ return (SaxElementOpen n as))+ `onFail` fail "missing > or /> in element tag" saxelementclose :: XParser SaxElement saxelementclose = do- tok TokEndOpen- n <- name- tok TokAnyClose- return (SaxElementClose n)+ tok TokEndOpen+ n <- name+ tok TokAnyClose+ return (SaxElementClose n) saxcomment :: XParser SaxElement-saxcomment = comment >>= return . SaxComment+saxcomment = SaxComment <$> comment saxchardata :: XParser SaxElement saxchardata =- (cdsect >>= return . SaxCharData)+ (SaxCharData <$>cdsect) `onFail`- (chardata >>= return . SaxCharData)+ (SaxCharData <$>chardata) saxreference :: XParser SaxElement-saxreference = reference >>= return . SaxReference+saxreference = SaxReference <$> reference saxdoctypedecl :: XParser SaxElement-saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl+saxdoctypedecl = SaxDocTypeDecl <$> doctypedecl saxprocessinginstruction :: XParser SaxElement saxprocessinginstruction = fmap SaxProcessingInstruction processinginstruction
src/Text/XML/HaXml/Schema/Environment.hs view
@@ -56,6 +56,7 @@ , env_substGrp :: Map QName [(QName,FilePath)] -- ^ substitution groups , env_typeloc :: Map QName FilePath -- ^ where type is defined }+ deriving (Show, Eq) -- | An empty environment of XSD type mappings. emptyEnv :: Environment@@ -85,7 +86,7 @@ -- think about qualification, w.r.t targetNamespace, elementFormDefault, etc item env (Include _ _) = env item env (Import _ _ _) = env- item env (Redefine _ _) = env -- revisit this+ item env (Redefine _ _) = env -- revisit this item env (Annotation _) = env item env (Simple st) = simple env st item env (Complex ct) = complex env ct@@ -194,4 +195,3 @@ [ (f,Nothing) | (Include f _) <- schema_items s ] ++ [ (f,ns) | (Import uri f _) <- schema_items s , let ns = targetPrefix (Just uri) (schema_namespaces s) ]-
src/Text/XML/HaXml/Schema/HaskellTypeModel.hs view
@@ -189,7 +189,6 @@ xsdinclude _ = False xsdimport (XSDImport _ _ _) = True xsdimport _ = False- xsdQualification nss = fmap (XName . N . nsPrefix) $+ xsdQualification nss = XName . N . nsPrefix <$> lookupBy ((==xsd).nsURI) nss where xsd = "http://www.w3.org/2001/XMLSchema"-
src/Text/XML/HaXml/Schema/NameConversion.hs view
@@ -59,12 +59,19 @@ local = (:[]) . Prelude.last . hierarchy + mkConid [] = "Empty" mkConid [c] | map toLower c == "string" = "Xsd.XsdString"- | otherwise = first toUpper c+ | otherwise = first toUpper $ map escape c mkConid [m,c] | map toLower c == "string" = "Xsd.XsdString"- | otherwise = first toUpper m++"."++first toUpper c- mkVarid [v] = first toLower v- mkVarid [m,v] = first toUpper m++"."++first toLower v+ | map toLower c == "date" = "Xsd.Date"+ | map toLower c == "double" = "Xsd.Double"+ | map toLower c == "integer" = "Xsd.Integer"+ | map toLower c == "boolean" = "Xsd.Boolean"+ | map toLower c == "decimal" = "Xsd.Decimal"+ | otherwise = first toUpper (map escape m)++"."++first toUpper (map escape c)+ mkConid more = mkConid [concat more]+ mkVarid [v] = first toLower (map escape v)+ mkVarid [m,v] = first toUpper m++"."++first toLower (map escape v) first f (x:xs) | not (isAlpha x) = f 'v': x: xs@@ -72,6 +79,13 @@ last f [x] = [ f x ] last f (x:xs) = x: last f xs +-- | Character escapes to create a valid Haskell identifier.+escape :: Char -> Char+escape x | x==' ' = '_'+ | x=='_' = '_'+ | isAlphaNum x = x+ | otherwise = '\''+ -- cleanUp = map (\c-> if not (isAlphaNum c) then '_' else c) -- | Ensure that a string does not match a Haskell keyword.@@ -91,8 +105,7 @@ -- e.g. fpml-dividend-swaps-4-7.xsd becomes FpML.V47.Swaps.Dividend -- but fpml-posttrade-execution-4-7.xsd becomes FpML.V47.PostTrade.Execution fpml :: String -> String-fpml = concat- . intersperse "." -- put the dots in+fpml = intercalate "." -- put the dots in . ("Data":) -- root of the Haskell module namespace . rearrange -- hierarchy shuffling, dependent on names . map cap -- make into nice module names@@ -152,9 +165,10 @@ let t = mkVarId . local $ qnt f = mkVarId . local $ qnf in HName $ if t==f then f- else if t `isPrefixOf` f- then t ++"_"++ mkVarId (drop (length t) f)- else mkVarId (shorten (mkConId t)) ++"_"++ f+ else mkVarId (shorten (mkConId t)) ++"_"+++ if t `isPrefixOf` f+ then mkVarId (drop (length t) f)+ else f } where hierarchy (N n) = wordsBy (==':') n@@ -162,15 +176,15 @@ local = Prelude.last . hierarchy - mkVarId ("id") = "ID"- mkVarId (v:vs) = toLower v: vs- mkConId (v:vs) = toUpper v: vs+ mkVarId "id" = "ID"+ mkVarId (v:vs) = toLower v: map escape vs+ mkConId (v:vs) = toUpper v: map escape vs shorten t | length t <= 12 = t | length t < 35 = concatMap shortenWord (splitWords t) | otherwise = map toLower (head t: filter isUpper (tail t)) splitWords "" = []- splitWords (u:s) = let (w,rest) = span (not . isUpper) s+ splitWords (u:s) = let (w,rest) = break (\c->isUpper c || c=='_') s in (u:w) : splitWords rest shortenWord "Request" = "Req" -- some special cases@@ -195,10 +209,13 @@ shortenWord "Property" = "Prop" shortenWord "Affirmation" = "Affirmation" shortenWord "Affirmed" = "Affirmed"+ shortenWord "KnockIn" = "KnockIn" -- avoid shortening+ shortenWord "Knockin" = "Knockin"+ shortenWord "KnockOut" = "KnockOut"+ shortenWord "Knockout" = "Knockout" shortenWord w | length w < 8 = w -- then the general rule | otherwise = case splitAt 5 w of (pref,c:suf) | isVowel c -> pref | otherwise -> pref++[c] isVowel = (`elem` "aeiouy")-
src/Text/XML/HaXml/Schema/Parse.hs view
@@ -23,15 +23,14 @@ -- | Qualify an ordinary name with the XSD namespace. xsd :: Name -> QName-xsd name = QN Namespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"}- name+xsd = QN Namespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"} -- | Predicate for comparing against an XSD-qualified name. (Also accepts -- unqualified names, but this is probably a bit too lax. Doing it right -- would require checking to see whether the current schema module's default -- namespace is XSD or not.) xsdTag :: String -> Content Posn -> Bool-xsdTag tag (CElem (Elem qn _ _) _) = qn == xsd tag || qn == (N tag)+xsdTag tag (CElem (Elem qn _ _) _) = qn == xsd tag || qn == N tag xsdTag _ _ = False -- | We need a Parser monad for reading from a sequence of generic XML@@ -124,7 +123,7 @@ ++printableName qn++"=\"" ++show atv++"\": "++msg Success [] v -> Success [] v- Success xs _ -> Committed $ + Success xs _ -> Committed $ Failure xs $ "Attribute parsing excess text: " ++printableName qn++"=\""@@ -157,7 +156,7 @@ -- me the prefix corresponding to the targetNamespace. targetPrefix :: Maybe TargetNamespace -> [Namespace] -> Maybe String targetPrefix Nothing _ = Nothing-targetPrefix (Just uri) nss = fmap nsPrefix $ lookupBy ((==uri).nsURI) nss+targetPrefix (Just uri) nss = nsPrefix <$> lookupBy ((==uri).nsURI) nss -- | An auxiliary you might expect to find in Data.List lookupBy :: (a->Bool) -> [a] -> Maybe a@@ -207,14 +206,13 @@ definiteAnnotation :: XsdParser Annotation definiteAnnotation = do e <- xsdElement "annotation"- ( fmap Documentation $ interiorWith (xsdTag "documentation")- (allChildren text) e- ) `onFail` (- fmap AppInfo $ interiorWith (xsdTag "documentation")- (allChildren text) e- ) `onFail` (+ ( Documentation <$> interiorWith (xsdTag "documentation")+ (allChildren text) e)+ `onFail`+ (AppInfo <$> interiorWith (xsdTag "documentation")+ (allChildren text) e)+ `onFail` return (NoAnnotation "failed to parse")- ) -- | Parse a FormDefault attribute. qform :: TextParser QForm@@ -243,7 +241,7 @@ schemaItem qual = oneOf' [ ("xsd:include", include) , ("xsd:import", import_)- , ("xsd:redefine", (redefine qual))+ , ("xsd:redefine", redefine qual) , ("xsd:annotation", fmap Annotation definiteAnnotation) -- , ("xsd:simpleType", fmap Simple (simpleType qual))@@ -253,6 +251,19 @@ , ("xsd:attributeGroup", fmap AttributeGroup (attributeGroup qual)) , ("xsd:group", fmap SchemaGroup (group_ qual)) -- , ("xsd:notation", notation)+-- sigh+ , ("xs:include", include)+ , ("xs:import", import_)+ , ("xs:redefine", redefine qual)+ , ("xs:annotation", fmap Annotation definiteAnnotation)+ --+ , ("xs:simpleType", fmap Simple (simpleType qual))+ , ("xs:complexType", fmap Complex (complexType qual))+ , ("xs:element", fmap SchemaElement (elementDecl qual))+ , ("xs:attribute", fmap SchemaAttribute (attributeDecl qual))+ , ("xs:attributeGroup", fmap AttributeGroup (attributeGroup qual))+ , ("xs:group", fmap SchemaGroup (group_ qual))+ -- , ("xs:notation", notation) ] -- | Parse an <xsd:include>.@@ -281,7 +292,7 @@ simpleType :: (String->String->QName) -> XsdParser SimpleType simpleType q = do e <- xsdElement "simpleType"- n <- optional (attribute (N "name") name e)+ n <- optional (attribute (N "name") string e) f <- optional (attribute (N "final") final e) a <- interiorWith (xsdTag "annotation") annotation e commit $ interiorWith (not . xsdTag "annotation") (simpleItem n f a) e@@ -320,8 +331,8 @@ restriction1 a b = return (RestrictSim1 a b) `apply` (return Restriction1 `apply` particle q) restrictType a b = return (RestrictType a b)- `apply` (optional (simpleType q))- `apply` many aFacet+ `apply` optional (simpleType q)+ `apply` many1 aFacet aFacet :: XsdParser Facet aFacet = foldr onFail (fail "Could not recognise simpleType Facet")@@ -372,7 +383,7 @@ `apply` (attribute (N "mixed") bool e `onFail` return False) `apply` interiorWith (not.xsdTag "annotation") stuff e ) `onFail` (- do fmap ThisType $ particleAttrs q+ do ThisType <$> particleAttrs q ) where stuff :: XsdParser (Either Restriction1 Extension)@@ -519,9 +530,9 @@ `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` (attribute (N "use") use e `onFail` return Optional)- `apply` (optional (attribute (N "default") (fmap Left string) e+ `apply` optional (attribute (N "default") (fmap Left string) e `onFail`- attribute (N "fixed") (fmap Right string) e))+ attribute (N "fixed") (fmap Right string) e) `apply` (attribute (xsd "form") qform e `onFail` return Unqualified) `apply` interiorWith (xsdTag "simpleType") (optional (simpleType q)) e@@ -530,8 +541,8 @@ -- | Parse an occurrence range from attributes of given element. occurs :: Element Posn -> XsdParser Occurs occurs e = return Occurs- `apply` (optional $ attribute (N "minOccurs") parseDec e)- `apply` (optional $ attribute (N "maxOccurs") maxDec e)+ `apply` optional (attribute (N "minOccurs") parseDec e)+ `apply` optional (attribute (N "maxOccurs") maxDec e) where maxDec = parseDec `onFail`@@ -598,8 +609,11 @@ -- | Text parser for an arbitrary string consisting of possibly multiple tokens. string :: TextParser String-string = fmap concat $ many word+string = concat <$> many (space `onFail` word) +space :: TextParser String+space = many1 $ satisfy isSpace+ -- | Parse a textual boolean, i.e. "true", "false", "0", or "1" bool :: TextParser Bool bool = do w <- word@@ -632,13 +646,9 @@ -- | Parse an attribute value that should be a QName. qname :: (String->String->QName) -> TextParser QName qname q = do a <- word- ( do ":" <- word- b <- many (satisfy (/=':'))- return (q a b)+ do ":" <- word+ b <- many (satisfy (/=':'))+ return (q a b) `onFail`- do cs <- many next- return (N (a++cs)) )---- | Parse an attribute value that should be a simple Name.-name :: TextParser Name-name = word+ do cs <- many next+ return (N (a++cs))
src/Text/XML/HaXml/Schema/PrettyHaskell.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | Pretty-print the internal Haskell model of XSD datatypes to a real -- Haskell module containing type declarations, and instances for parsing -- (and printing - though not yet implemented) values of those datatypes@@ -10,6 +11,10 @@ , ppvList ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+ import Text.XML.HaXml.Types (QName(..),Namespace(..)) import Text.XML.HaXml.Schema.HaskellTypeModel import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))@@ -34,12 +39,14 @@ -- (but without escapes in comment text yet) ppComment :: CommentPosition -> Comment -> Doc ppComment _ Nothing = empty-ppComment pos (Just s) =- text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c- $$- vcat (map (\x-> text "-- " <+> text x) cs)+ppComment pos (Just s) = case ps of+ (c:cs) ->+ text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c+ $$+ vcat (map (\x-> text "-- " <+> text x) cs)+ [] -> empty where- (c:cs) = lines (paragraph 60 s)+ ps = lines (paragraph 60 s) -- | Generate aligned haddock-style docs for choices (where each choice -- has its own documentation, but haddock cannot place it directly next@@ -62,11 +69,10 @@ ++paragraph 52 s) seq) [1..]- $ map (map safeComment)- $ nested+ $ map (map safeComment) nested safeComment Text = "mixed text" safeComment e@Element{} = fromMaybe (xname $ elem_name e) (elem_comment e)- safeComment e@_ = fromMaybe ("unknown") (elem_comment e)+ safeComment e = fromMaybe "unknown" (elem_comment e) xname (XName (N x)) = x xname (XName (QN ns x)) = nsPrefix ns++":"++x @@ -91,7 +97,7 @@ ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q)-ppFieldId nx = \t-> ppHName . fieldid nx t+ppFieldId nx t = ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc@@ -241,11 +247,11 @@ <+> text "where" $$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") )- $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "x) = " + $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "x) = " $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]") ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where"@@ -278,7 +284,7 @@ $$ nest 4 (ppFields nx t_attrs [] as $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]" $$ text "commit $ do" $$ nest 2@@ -329,11 +335,11 @@ $$ text "data" <+> ppUnqConId nx t $$ nest 4 ( ppvList "=" "|" "deriving (Eq,Show,Enum)" item is ) $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") )- $$ nest 4 (text "schemaTypeToXML s x = " + $$ nest 4 (text "schemaTypeToXML s x = " $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]") ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where"@@ -343,7 +349,7 @@ where item (i,c) = (ppUnqConId nx t <> text "_" <> ppConId nx i) $$ ppComment After c- parseItem (i,_) = text "do isWord \"" <> ppXName i <> text "\"; return"+ parseItem (i,_) = text "do literal \"" <> ppXName i <> text "\"; return" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i) enumText (i,_) = text "simpleTypeText" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i)@@ -355,7 +361,7 @@ $$ nest 8 (ppFields nx t (uniqueify es) as $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]" -- $$ text "commit $ do" -- $$ nest 2@@ -407,7 +413,7 @@ -- <+> text "(declared in Instance module)" -- *** Declare instance here $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (vcat (intersperse (text "`onFail`") (map ppParse insts) ++ [text "`onFail` fail" <+> errmsg])))@@ -479,7 +485,7 @@ -- = (text "-- element" <> ppUnqConId nx n) <+> text "::" -- <+> text "XMLParser" <+> ppConId nx t -- $$ text "-- declared in Instances module"- | otherwise = ppComment Before comm+{- | otherwise-} = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "element" <> ppUnqConId nx n) <+> text "="@@ -527,7 +533,7 @@ -- $$ text "data" <+> ppConId nx t <+> text "=" -- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es) --- Possibly we want to declare a really more restrictive type, e.g. +-- Possibly we want to declare a really more restrictive type, e.g. -- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo -- consequently the "restricts" method should do a proper translation, -- not merely an unwrapping.@@ -544,7 +550,7 @@ $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType = fmap " <+> ppUnqConId nx t <+> text ". parseSchemaType")- -- XXX should enforce the restriction.+ -- XXX should enforce the restriction. $$ nest 4 (text "schemaTypeToXML s (" <> ppUnqConId nx t <+> text "x)") <+> text "= schemaTypeToXML s x" @@ -598,7 +604,7 @@ ppHighLevelInstances :: NameConverter -> Decl -> Doc ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) = text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"- $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (vcat (intersperse (text "`onFail`") (map ppParse insts) ++ [text "`onFail` fail" <+> errmsg])))@@ -716,14 +722,14 @@ <+> text "will be declared later in module" <+> ppModId nx mod $$ ppSuperExtension nx super grandSupers (t,Nothing) ppSuperExtension nx super grandSupers (t,Nothing) =- vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers))+ vcat (map (ppSuper t . reverse) (drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx gs <+> text "where" $$ nest 4 (text "supertype" <+>- (ppvList "=" "." "" coerce (zip (tail gss++[t]) gss)))+ ppvList "=" "." "" coerce (zip (tail gss++[t]) gss)) coerce (a,b) = text "(supertype ::" <+> ppUnqConId nx a <+> text "->" <+> ppConId nx b <> text ")"@@ -754,15 +760,15 @@ -- | Generate a single named field (no type sig) from an element. ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc ppFieldName nx t e@Element{} _ = ppFieldId nx t (elem_name e)-ppFieldName nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i)-ppFieldName nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i)-ppFieldName nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i)+ppFieldName nx t e@OneOf{} i = ppFieldId nx t (XName $ N $ "choice"++show i)+ppFieldName nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $ "any"++show i)+ppFieldName nx t e@Text{} i = ppFieldId nx t (XName $ N $ "text"++show i) -- | What is the name of the type for an Element (or choice of Elements)? ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e)-ppElemTypeName nx brack e@OneOf{} = +ppElemTypeName nx brack e@OneOf{} = brack $ ppTypeModifier (liftedElemModifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e))) <+> hsep (map (ppSeq . cleanChoices) (elem_oneOf e))@@ -873,7 +879,6 @@ | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $- dropWhile pred [(n++show i) | i <- [2..]]+ dropWhile pred [n++show i | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $- dropWhile pred [(n++show i) | i <- [2..]]-+ dropWhile pred [n++show i | i <- [2..]]
src/Text/XML/HaXml/Schema/PrettyHsBoot.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | Pretty-print the internal Haskell model of XSD datatypes to a -- Haskell hs-boot module containing only stub type declarations. -- This approach is intended to work around issues of mutually recursive@@ -10,6 +11,10 @@ , ppvList ) where +#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+ import Text.XML.HaXml.Types (QName(..),Namespace(..)) import Text.XML.HaXml.Schema.HaskellTypeModel import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))@@ -61,7 +66,7 @@ ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q)-ppFieldId nx = \t-> ppHName . fieldid nx t+ppFieldId nx t = ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc@@ -222,7 +227,7 @@ -- $$ text "data" <+> ppConId nx t <+> text "=" -- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es) --- Possibly we want to declare a really more restrictive type, e.g. +-- Possibly we want to declare a really more restrictive type, e.g. -- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo -- consequently the "restricts" method should do a proper translation, -- not merely an unwrapping.@@ -345,7 +350,7 @@ text "-- instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper $$ text "-- will be declared in module" <+> ppModId nx mod ppSuperExtension nx super grandSupers (t,Nothing) =- vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers))+ vcat (map (ppSuper t . reverse) (drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) =@@ -364,20 +369,20 @@ ppFieldElement nx t e@Element{} _ = ppFieldId nx t (elem_name e) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e)-ppFieldElement nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i)+ppFieldElement nx t e@OneOf{} i = ppFieldId nx t (XName $ N $ "choice"++show i) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e)-ppFieldElement nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i)+ppFieldElement nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $ "any"++show i) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e)-ppFieldElement nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i)+ppFieldElement nx t e@Text{} i = ppFieldId nx t (XName $ N $ "text"++show i) <+> text "::" <+> ppElemTypeName nx id e -- | What is the name of the type for an Element (or choice of Elements)? ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e)-ppElemTypeName nx brack e@OneOf{} = +ppElemTypeName nx brack e@OneOf{} = brack $ ppTypeModifier (elem_modifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e))) <+> hsep (map ppSeq (elem_oneOf e))@@ -435,7 +440,6 @@ | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $- dropWhile pred [(n++show i) | i <- [2..]]+ dropWhile pred [n++show i | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $- dropWhile pred [(n++show i) | i <- [2..]]-+ dropWhile pred [n++show i | i <- [2..]]
src/Text/XML/HaXml/Schema/PrimitiveTypes.hs view
@@ -129,13 +129,13 @@ instance SimpleType Decimal where acceptingParser = fmap Decimal parse- simpleTypeText (Decimal s) = show s -- XXX FIXME: showGFloat?+ simpleTypeText (Decimal s) = show s -- XXX FIXME: showGFloat? instance SimpleType Float where acceptingParser = parse- simpleTypeText x = show x -- XXX FIXME: showGFloat?+ simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Double where acceptingParser = parse- simpleTypeText x = show x -- XXX FIXME: showGFloat?+ simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Duration where acceptingParser = return Duration `apply` (do isNext '-'; return False@@ -155,10 +155,13 @@ `onFail` return 0) `apply` ((parseFloat `discard` isNext 'S') `onFail` return 0)+ simpleTypeText (Duration pos 0 0 0 0 0 0) = (if pos then "" else "-")++"PT0S" simpleTypeText (Duration pos y m d h n s) =- (if pos then "" else "-")++show y++"Y"++show m++"M"++show d++"D"- ++"T"++show h++"H"++show n++"M"++show s++"S"-+ (if pos then "" else "-")++"P"++showUnit y 'Y'++showUnit m 'M'++showUnit d 'D'++showTime+ where+ showUnit :: (Num a,Eq a,Show a) => a -> Char -> String+ showUnit n u = if n == 0 then "" else show n ++ [u]+ showTime = if (h,n,s) == (0,0,0) then "" else "T"++showUnit h 'H'++showUnit n 'M'++showUnit s 'S' instance SimpleType DateTime where acceptingParser = fmap DateTime (many next) -- acceptingParser = fail "not implemented: simpletype parser for DateTime"@@ -194,7 +197,7 @@ -- * Derived builtin types -newtype NormalizedString = Normalized String deriving (Eq,Show)+newtype NormalizedString = Normalized String deriving (Eq,Show) newtype Token = Token String deriving (Eq,Show) newtype Language = Language String deriving (Eq,Show) newtype Name = Name String deriving (Eq,Show)@@ -297,4 +300,3 @@ instance SimpleType PositiveInteger where acceptingParser = fmap Positive parse simpleTypeText (Positive x) = show x-
src/Text/XML/HaXml/Schema/Schema.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,+{-# LANGUAGE CPP, FunctionalDependencies, TypeSynonymInstances, ExistentialQuantification #-} module Text.XML.HaXml.Schema.Schema ( SchemaType(..)@@ -32,6 +32,7 @@ , addXMLAttributes ) where +import Control.Monad (void) import Text.ParserCombinators.Poly import Text.Parse @@ -40,7 +41,6 @@ import Text.XML.HaXml.Namespaces (printableName) import Text.XML.HaXml.XmlContent.Parser hiding (Document,Reference) import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))-import Text.XML.HaXml.Schema.PrimitiveTypes import Text.XML.HaXml.Schema.PrimitiveTypes as Prim import Text.XML.HaXml.OneOfN import Text.XML.HaXml.Verbatim@@ -70,7 +70,7 @@ -- | Given a TextParser for a SimpleType, make it into an XMLParser, i.e. -- consuming textual XML content as input rather than a String. parseSimpleType :: SimpleType t => XMLParser t-parseSimpleType = do s <- text+parseSimpleType = do s <- text `onFail` return "" case runParser acceptingParser s of (Left err, _) -> fail err (Right v, "") -> return v@@ -147,7 +147,7 @@ [CString False text ()] toXMLAnyElement :: AnyElement -> [Content ()]-toXMLAnyElement (UnconvertedANY c) = [fmap (const ()) c]+toXMLAnyElement (UnconvertedANY c) = [void c] --toXMLAnyElement (ANYSchemaType x) = [c] toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute]@@ -204,7 +204,7 @@ -- Ensure that all primitive/simple types can also be used as elements. -#define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e $ parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] }+#define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] } SchemaInstance(XsdString) SchemaInstance(Prim.Boolean)@@ -249,4 +249,3 @@ SchemaInstance(Prim.UnsignedShort) SchemaInstance(Prim.UnsignedByte) SchemaInstance(Prim.PositiveInteger)-
src/Text/XML/HaXml/Schema/TypeConversion.hs view
@@ -12,11 +12,86 @@ import Text.XML.HaXml.Schema.Parse (xsd) import qualified Data.Map as Map+import Data.Semigroup (Semigroup (..)) import Data.Map (Map) import Data.List (foldl') import Data.Maybe (fromMaybe,fromJust,isNothing,isJust)-import Data.Monoid+import Data.Monoid (Monoid (..)) +-- | Transform a Schema by lifting all locally-defined anonymous types to+-- the top-level, naming them, and planting a referend at their original+-- location.+typeLift :: Schema -> Schema+typeLift s = s{ schema_items =+ concat [ hoist e | SchemaElement e <- schema_items s ]+ ++ map renameLocals (schema_items s) }+ where+ hoist :: ElementDecl -> [SchemaItem]+ hoist e =+ let only_children = filter (not . (==) e) $ findE e+ in flip concatMap only_children $+ \e@ElementDecl{elem_nameOrRef=Left (NT{ theName=n+ {-, theType=Nothing-}})}->+ localType n (elem_content e)++ findE :: ElementDecl -> [ElementDecl]+ findE e = ( case elem_nameOrRef e of+ Left (NT{theType=Nothing}) -> (e:)+ Left (NT{theType=Just t}) -> case elem_content e of+ Just (Right+ (ComplexType+ {complex_name=Just t'}))+ {--| t==t'-}+ -> (e:)+ _ -> id+ _ -> id+ )+ ( case elem_content e of+ Nothing -> []+ Just (Left _) -> []+ Just (Right c) ->+ case complex_content c of+ v@SimpleContent{ci_stuff=Left (Restriction1 p)} -> particle p+ v@SimpleContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p+ v@ComplexContent{ci_stuff=Left (Restriction1 p)} -> particle p+ v@ComplexContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p+ v@ThisType{ci_thistype=PA p _ _} -> particle p+ )+ particle Nothing = []+ particle (Just (Left cos)) = choiceOrSeq cos+ particle (Just (Right g)) = maybe [] choiceOrSeq $ group_stuff g+ choiceOrSeq (XSD.All _ es) = concatMap findE es+ choiceOrSeq (XSD.Choice _ _ es) = concatMap etc es+ choiceOrSeq (XSD.Sequence _ _ es) = concatMap etc es+ etc (HasElement e) = findE e+ etc (HasGroup g) = maybe [] choiceOrSeq $ group_stuff g+ etc (HasCS cos) = choiceOrSeq cos+ etc (HasAny _) = []++ localType n Nothing = []+ localType n (Just (Left s)) = [Simple (renameSimple n s)]+ localType n (Just (Right c)) = [Complex c{ complex_name = Just n }]++ renameSimple n s@Primitive{} = s+ renameSimple n s@Restricted{} = s{ simple_name = Just n }+ renameSimple n s@ListOf{} = s{ simple_name = Just n }+ renameSimple n s@UnionOf{} = s{ simple_name = Just n }+++ -- * For now, rather than walk the tree, giving typenames to nodes that were+ -- previously locally-typed, we will instead assume in the pretty-printer+ -- that it can always replace a missing typename with the element name, and+ -- have it resolve to something sensible.+ renameLocals :: SchemaItem -> SchemaItem+ renameLocals s = s+-- renameLocals (SchemaElement e)+-- | Left (NT{theName=n,theType=Nothing}) <- elem_nameOrRef e+-- = SchemaElement e{ elem_nameOrRef = Left (NT{theName=n+-- ,theType=Just n})+-- }+-- -- still gotta do the recursive search + rename++ -- | Given an environment of schema type mappings, and a schema module, -- create a bunch of Decls that describe the types in a more -- Haskell-friendly way.@@ -25,7 +100,7 @@ where item (Include loc ann) = [XSDInclude (xname loc) (comment ann)] item (Import uri loc ann) = [XSDImport (xname loc)- (fmap xname $+ (xname <$> Map.lookup uri (env_namespace env)) (comment ann)] item (Redefine _ _) = [] -- ignoring redefinitions for now@@ -40,7 +115,7 @@ simple (Primitive prim) = [] simple s@(Restricted a n f r) | (Just enums) <- isEnumeration s- = [EnumSimpleType + = [EnumSimpleType (maybe (error "missing Name") xname n) enums (comment a) ] | otherwise = [RestrictSimpleType@@ -54,7 +129,7 @@ -- (comment a)] simple s@(UnionOf a n f u m) | (Just enums) <- isEnumeration s- = [EnumSimpleType + = [EnumSimpleType (maybe (error "missing Name") xname n) enums (comment a) ] | otherwise = [UnionSimpleTypes@@ -82,14 +157,14 @@ squeeze xs [] = Just xs complex ct =- let nx = N $ fromMaybe ("errorMissingName") (complex_name ct)+ let nx = N $ fromMaybe "errorMissingName" (complex_name ct) n = XName nx in singleton $ case complex_content ct of c@SimpleContent{} -> case ci_stuff c of Left r ->- RestrictSimpleType n ({-simple-}xname $ "Unimplemented") []+ RestrictSimpleType n ({-simple-}xname "Unimplemented") [] (comment (complex_annotation ct `mappend` ci_annotation c)) Right e ->@@ -103,7 +178,7 @@ c@ComplexContent{} -> case ci_stuff c of Left r ->- RestrictComplexType n ({-complex-}xname $ "Can'tBeRight")+ RestrictComplexType n ({-complex-}xname "Can'tBeRight") (comment (complex_annotation ct `mappend` ci_annotation c)) Right e ->@@ -138,10 +213,10 @@ in ExtendComplexType n ({-supertype-}XName $ extension_base e)- ({-supertype elems-}oldEs)- ({-supertype attrs-}oldAs)- ({-elems-}es)- ({-attrs-}as)+ {-supertype elems-}oldEs+ {-supertype attrs-}oldAs+ {-elems-}es+ {-attrs-}as ({-fwddecl-}if myLoc/=supLoc then Just (xname supLoc) else Nothing) ({-abstract supertype-}@@ -156,14 +231,15 @@ `mappend` extension_annotation e)) c@ThisType{} | complex_abstract ct -> let myLoc = fromMaybe "NUL"- (Map.lookup nx (env_typeloc env)) in+ (Map.lookup nx (env_typeloc env)) in ElementsAttrsAbstract n {-all instance types: -}- (map (\ (x,loc)->(XName x,if loc/=myLoc- then Just (xname loc)- else Nothing))- $ fromMaybe []- $ Map.lookup nx (env_extendty env))+ (case Map.lookup nx (env_extendty env) of+ Nothing -> []+ Just xs -> map (\ (x,loc)->(XName x,if loc/=myLoc+ then Just (xname loc)+ else Nothing)) xs+ ) (comment (complex_annotation ct)) c@ThisType{} | otherwise -> let (es,as) = particleAttrs (ci_thistype c)@@ -183,20 +259,20 @@ --I'm pretty sure a topElementDecl can't be abstract... let (es,as) = contentInfo (elem_content ed) in [ ElementsAttrs ({-name-}xname $ theName n)- ({-elems-}es)- ({-attrs-}as)+ {-elems-}es+ {-attrs-}as (comment (elem_annotation ed))- , ElementOfType- Element{ elem_name = xname (theName n)- , elem_type = checkXName s (N $ theName n)- , elem_modifier =- Haskell.Range (elem_occurs ed)- , elem_byRef = False- , elem_locals = []- , elem_substs = Nothing- , elem_comment =- (comment (elem_annotation ed))- }+ , ElementOfType $ elementDecl ed+ -- Element{ elem_name = xname (theName n)+ -- , elem_type = checkXName s (N $ theName n)+ -- , elem_modifier =+ -- occursToModifier (elem_occurs ed)+ -- , elem_byRef = False+ -- , elem_locals = []+ -- , elem_substs = Nothing+ -- , elem_comment =+ -- (comment (elem_annotation ed))+ -- } ] Just t | elem_abstract ed -> let nm = N $ theName n@@ -206,59 +282,63 @@ ElementAbstractOfType (XName nm) (checkXName s t)- (map (\ (x,loc)->(XName x,if loc/=myLoc- then Just (xname loc)- else Nothing))- $ fromMaybe []- $ Map.lookup nm (env_substGrp env))+ (case Map.lookup nm (env_substGrp env) of+ Nothing -> []+ Just xs ->+ map (\ (x,loc)->(XName x,+ if loc/=myLoc+ then Just (xname loc)+ else Nothing)) xs) (comment (elem_annotation ed)) Just t | otherwise ->- singleton $ ElementOfType $- Element{ elem_name = xname $ theName n- , elem_type = checkXName s t- , elem_modifier= Haskell.Range (elem_occurs ed)- , elem_byRef = False- , elem_locals = []- , elem_substs = Nothing- -- , elem_substs = if elem_abstract ed- -- then fmap (map XName) $- -- Map.lookup (N $ theName n)- -- (env_substGrp env)- -- else Nothing- , elem_comment = comment (elem_annotation ed)- }+ singleton $ ElementOfType $ elementDecl ed+ -- Element{ elem_name = xname $ theName n+ -- , elem_type = checkXName s t+ -- , elem_modifier=+ -- occursToModifier (elem_occurs ed)+ -- , elem_byRef = False+ -- , elem_locals = []+ -- , elem_substs = Nothing+ -- , elem_comment = comment (elem_annotation ed)+ -- } Right ref -> case Map.lookup ref (env_element env) of- Nothing -> error $ "<topElementDecl> unknown element reference "- ++printableName ref- Just e' -> topElementDecl e'+ Nothing -> error $ "<topElementDecl> unknown element reference "+ ++printableName ref+ Just e' -> topElementDecl e' elementDecl :: XSD.ElementDecl -> Haskell.Element elementDecl ed = case elem_nameOrRef ed of- Left n -> Element ({-name-}xname $ theName n)- ({-type-}maybe (localTypeExp ed)- XName- (theType n))- ({-modifier-}Haskell.Range $ elem_occurs ed)- False -- by reference- [] -- internal Decl- Nothing -- substitution group- (comment (elem_annotation ed))+ Left n -> Element { elem_name = xname $ theName n+ , elem_type = maybe (localTypeExp ed)+ (checkXName s)+ (theType n)+ , elem_modifier = occursToModifier $ elem_occurs ed+ , elem_byRef = False -- by reference+ , elem_locals = [] -- internal Decl+ , elem_substs = Nothing -- substitution group+ -- , elem_substs = if elem_abstract ed+ -- then fmap (map XName) $+ -- Map.lookup (N $ theName n)+ -- (env_substGrp env)+ -- else Nothing+ , elem_comment = comment $ elem_annotation ed+ } Right ref -> case Map.lookup ref (env_element env) of Just e' -> (elementDecl e') { elem_modifier =- Haskell.Range (elem_occurs ed)+ occursToModifier (elem_occurs ed) , elem_byRef = True } Nothing -> -- possible ref is imported qualified? case Map.lookup (N $ localName ref) (env_element env) of Just e' -> (elementDecl e') { elem_modifier =- Haskell.Range (elem_occurs ed)+ occursToModifier (elem_occurs ed) , elem_byRef = True } Nothing -> Element ({-name-}XName ref) -- best guess at type ({-type-}XName ref)- (Haskell.Range (elem_occurs ed))+ (occursToModifier (elem_occurs ed)) True [] Nothing Nothing localTypeExp :: XSD.ElementDecl -> XName@@ -267,24 +347,27 @@ Left st@Primitive{} -> xname "SomethingPrimitive" Left st@Restricted{} -> (\x-> maybe x xname (simple_name st)) $- (maybe (xname "GiveUp")- XName $- restrict_base $- simple_restriction st)+ maybe (xname "GiveUp")+ XName+ (restrict_base $+ simple_restriction st) Left st@ListOf{} -> xname "SomethingListy" Left st@UnionOf{} -> xname "SomethingUnionLike"- Right c@ComplexType{} -> xname $ fromMaybe "unknown"+ Right c@ComplexType{} -> maybe (localTypeExp ed{elem_content=Nothing})+ xname $ complex_name c | otherwise = case elem_nameOrRef ed of Left n -> xname $ theName n- Right _ -> xname $ "unknownElement"+ Right _ -> xname "unknownElement" attributeDecl :: XSD.AttributeDecl -> [Haskell.Attribute] attributeDecl ad = case attr_nameOrRef ad of Left n -> singleton $ Attribute (xname $ theName n)- (maybe (maybe (error "XSD.attributeDecl->")+ (maybe (maybe (xname "String")+ -- guess at an attribute typename?+ --(error "XSD.attributeDecl->") nameOfSimple (attr_simpleType ad)) XName@@ -307,18 +390,27 @@ group :: XSD.Group -> [Haskell.Decl] group g = case group_nameOrRef g of- Left n -> let ({-highs,-}es) = choiceOrSeq (fromMaybe (error "XSD.group")+ Left n -> let {-highs,-}es = choiceOrSeq (fromMaybe (error "XSD.group") (group_stuff g)) in {-highs ++-} singleton $- Haskell.Group (xname n) es+ Haskell.Group (xname n)+ (map (\e->e{elem_modifier=+ combineOccursModifier+ (group_occurs g)+ (elem_modifier e)})+ es) (comment (group_annotation g))+ Right (QN _ ref) -> case Map.lookup (N ref) (env_group env) of+ Nothing -> error $ "bad group reference "+ ++printableName (N ref)+ Just g' -> group g'{ group_occurs=group_occurs g } Right ref -> case Map.lookup ref (env_group env) of -- Nothing -> error $ "bad group reference " -- ++printableName ref Nothing -> singleton $ Haskell.Group (xname ("unknown-group-"++printableName ref)) [] (comment (group_annotation g))- Just g' -> group g'+ Just g' -> group g'{ group_occurs=group_occurs g } particleAttrs :: ParticleAttrs -> ([Haskell.Element],[Haskell.Attribute]) particleAttrs (PA part attrs _) = -- ignoring AnyAttr for now@@ -334,7 +426,7 @@ choiceOrSeq (XSD.All ann eds) = error "not yet implemented: XSD.All" choiceOrSeq (XSD.Choice ann o ees) = [ OneOf (anyToEnd (map elementEtc ees))- (Haskell.Range o)+ (occursToModifier o) (comment ann) ] choiceOrSeq (XSD.Sequence ann _ ees) = concatMap elementEtc ees @@ -346,16 +438,16 @@ any :: XSD.Any -> [Haskell.Element] any a@XSD.Any{} = [Haskell.AnyElem- { elem_modifier = Haskell.Range (any_occurs a)+ { elem_modifier = occursToModifier (any_occurs a) , elem_comment = comment (any_annotation a) }] -- If an ANY element is part of a choice, ensure it is the last part. anyToEnd :: [[Haskell.Element]] -> [[Haskell.Element]] anyToEnd = go Nothing- where go _ (e@[AnyElem{}]:[]) = e:[]+ where go _ [e@[AnyElem{}]] = [e] go _ (e@[AnyElem{}]:es) = go (Just e) es go Nothing [] = []- go (Just e) [] = e:[]+ go (Just e) [] = [e] go m (e:es) = e:go m es contentInfo :: Maybe (Either SimpleType ComplexType)@@ -403,35 +495,33 @@ nameOfSimple s = xname "String" -- anonymous simple mkRestrict :: XSD.Restriction -> [Haskell.Restrict]-mkRestrict (RestrictSim1 ann base r1) =- error "Not yet implemented: Restriction1 on simpletype"+mkRestrict (RestrictSim1 ann base r1) = []+-- = error "Not yet implemented: Restriction1 on simpletype"+-- ^ This branch is not strictly correct. There ought to be some+-- restrictions. mkRestrict (RestrictType _ _ _ facets) = (let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets , f `elem` [OrderedBoundsMinIncl ,OrderedBoundsMinExcl ,OrderedBoundsMaxIncl ,OrderedBoundsMaxExcl] ]- in if null occurs then []- else [Haskell.RangeR (foldl consolidate (Occurs Nothing Nothing) occurs)- (comment $ foldr mappend mempty- [ ann | (_,ann,_) <- occurs])]+ in [Haskell.RangeR (foldl consolidate (Occurs Nothing Nothing) occurs)+ (comment $ mconcat [ ann | (_,ann,_) <- occurs]) | null occurs] ) ++ [ Haskell.Pattern v (comment ann) | (Facet UnorderedPattern ann v _) <- facets ] ++ (let enum = [ (v,comment ann) | (Facet UnorderedEnumeration ann v _) <- facets ]- in if null enum then []- else [Haskell.Enumeration enum]+ in [Haskell.Enumeration enum | null enum] ) ++ (let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets , f `elem` [UnorderedLength ,UnorderedMaxLength ,UnorderedMinLength] ]- in if null occurs then []- else [Haskell.StrLength- (foldl consolidate (Occurs Nothing Nothing) occurs)- (comment $ foldr mappend mempty [ ann | (_,ann,_) <- occurs])]+ in [Haskell.StrLength+ (foldl consolidate (Occurs Nothing Nothing) occurs)+ (comment $ mconcat [ ann | (_,ann,_) <- occurs]) | null occurs] ) singleton :: a -> [a]@@ -442,17 +532,47 @@ consolidate (Occurs min max) (OrderedBoundsMinIncl,_,n) = Occurs (Just (read n)) max consolidate (Occurs min max) (OrderedBoundsMinExcl,_,n) =- Occurs (Just ((read n)+1)) max+ Occurs (Just (read n +1)) max consolidate (Occurs min max) (OrderedBoundsMaxIncl,_,n) = Occurs min (Just (read n)) consolidate (Occurs min max) (OrderedBoundsMaxExcl,_,n) =- Occurs min (Just ((read n)-1))+ Occurs min (Just (read n -1)) consolidate (Occurs min max) (UnorderedLength,_,n) = Occurs (Just (read n)) (Just (read n)) consolidate (Occurs min max) (UnorderedMinLength,_,n) = Occurs (Just (read n)) max consolidate (Occurs min max) (UnorderedMaxLength,_,n) = Occurs min (Just (read n))++instance Monoid Occurs where+ mempty = Occurs Nothing Nothing+ mappend = (<>)++instance Semigroup Occurs where+ (Occurs Nothing Nothing) <> o = o+ (Occurs (Just z) Nothing) <> (Occurs min max)+ = Occurs (Just $ maybe z (*z) min) max+ (Occurs Nothing (Just x)) <> (Occurs min max)+ = Occurs min (Just $ maybe x (*x) max)+ (Occurs (Just z) (Just x)) <> (Occurs min max)+ = Occurs (Just $ maybe z (*z) min)+ (Just $ maybe x (*x) max)++-- | Push another Occurs value inside an existing Modifier.+combineOccursModifier :: Occurs -> Modifier -> Modifier+combineOccursModifier o Haskell.Single = occursToModifier $ mappend o+ $ Occurs (Just 1) (Just 1)+combineOccursModifier o Haskell.Optional = occursToModifier $ mappend o+ $ Occurs (Just 0) (Just 1)+combineOccursModifier o (Haskell.Range o') = occursToModifier $ mappend o o'++-- | Convert an occurs range to a Haskell-style type modifier (Maybe, List, Id)+occursToModifier :: Occurs -> Modifier+occursToModifier (Occurs Nothing Nothing) = Haskell.Single+occursToModifier (Occurs (Just 0) Nothing) = Haskell.Optional+occursToModifier (Occurs (Just 0) (Just 1)) = Haskell.Optional+occursToModifier (Occurs (Just 1) (Just 1)) = Haskell.Single+occursToModifier o = Haskell.Range o -- | Find the supertype (if it exists) of a given type name.
src/Text/XML/HaXml/Schema/XSDTypeModel.hs view
@@ -2,7 +2,8 @@ ( module Text.XML.HaXml.Schema.XSDTypeModel ) where -import Data.Monoid hiding (Any)+import Data.Semigroup (Semigroup (..))+import Data.Monoid (Monoid (..)) import Text.XML.HaXml.Types (Name,Namespace,QName) data Schema = Schema@@ -56,7 +57,7 @@ deriving (Eq,Show) data Restriction = RestrictSim1 { restrict_annotation :: Annotation- , restrict_base :: Maybe QName + , restrict_base :: Maybe QName , restrict_r1 :: Restriction1 } | RestrictType { restrict_annotation :: Annotation@@ -101,12 +102,12 @@ deriving (Eq,Show) data ComplexItem = SimpleContent { ci_annotation :: Annotation- , ci_stuff :: (Either Restriction1 Extension)+ , ci_stuff :: Either Restriction1 Extension } | ComplexContent { ci_annotation :: Annotation , ci_mixed :: Bool- , ci_stuff :: (Either Restriction1 Extension)+ , ci_stuff :: Either Restriction1 Extension } | ThisType { ci_thistype :: ParticleAttrs@@ -248,8 +249,8 @@ | Base64Binary | HexBinary | AnyURI | QName | Notation deriving (Eq,Show)- + data MyRestriction = Range Occurs | Pattern Regexp | Enumeration [String]@@ -293,15 +294,20 @@ instance Monoid Annotation where mempty = NoAnnotation "Monoid.mempty <Annotation>"- (Documentation d) `mappend` (Documentation e) = Documentation (d++"\n"++e)- _ `mappend` (Documentation e) = Documentation e- ann `mappend` _ = ann + mappend = (<>) --- This instance is pretty unsatisfactory, and is useful only for+instance Semigroup Annotation where+ (Documentation d) <> (Documentation e) = Documentation (d++"\n"++e)+ _ <> (Documentation e) = Documentation e+ ann <> _ = ann++-- | This instance is pretty unsatisfactory, and is useful only for -- building environments involving recursive modules. The /mappend/ -- method is left-biased, and the /mempty/ value contains lots of -- undefined values. instance Monoid Schema where mempty = Schema{ schema_items=[] }- s `mappend` t = s{ schema_items = schema_items s ++ schema_items t }+ mappend = (<>) +instance Semigroup Schema where+ s <> t = s{ schema_items = schema_items s ++ schema_items t }
src/Text/XML/HaXml/ShowXmlLazy.hs view
@@ -1,11 +1,17 @@+{-# LANGUAGE CPP #-} module Text.XML.HaXml.ShowXmlLazy (showXmlLazy) where import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.TypeMapping -- (toHType, toDTD, Tuple(), Defined, showHType) -import qualified Text.XML.HaXml.XmlContent as X+#if MIN_VERSION_base(4,11,0)+import Prelude hiding (maybe,either,(<>))+#else import Prelude hiding (maybe,either)+#endif++import qualified Text.XML.HaXml.XmlContent as X import Data.Maybe hiding (maybe) import Data.List @@ -140,8 +146,8 @@ text "<" <> qname n <+> fsep (map attribute as) , text "/>") carryelem (Elem n as cs) c--- | any isText cs = ( c <> element e, empty)- | otherwise = let (cs0,d0) = carryscan carrycontent cs (text ">")+{- | any isText cs = ( c <> element e, empty)+ | otherwise -} = let (cs0,d0) = carryscan carrycontent cs (text ">") in ( c <> text "<" <> qname n <+> fsep (map attribute as) $$@@ -327,4 +333,3 @@ containsDoubleQuote evs = any csq evs where csq (EVString s) = '"' `elem` s csq _ = False-
src/Text/XML/HaXml/TypeMapping.hs view
@@ -1,13 +1,13 @@ module Text.XML.HaXml.TypeMapping ( -- * A class to get an explicit type representation for any value- HTypeable(..) -- sole method, toHType+ HTypeable(..) -- sole method, toHType -- * Explicit representation of Haskell datatype information- , HType(..) -- instance of Eq, Show- , Constr(..) -- instance of Eq, Show+ , HType(..) -- instance of Eq, Show+ , Constr(..) -- instance of Eq, Show -- * Helper functions to extract type info as strings- , showHType -- :: HType -> ShowS- , showConstr -- :: Int -> HType -> String+ , showHType -- :: HType -> ShowS+ , showConstr -- :: Int -> HType -> String -- * Conversion from Haskell datatype to DTD , toDTD ) where@@ -38,9 +38,9 @@ | Prim String String -- ^ separate Haskell name and XML name | String | Defined String [HType] [Constr]- -- ^ A user-defined type has a name, a sequence of type variables,- -- and a set of constructors. (The variables might already be- -- instantiated to actual types.)+ -- ^ A user-defined type has a name, a sequence of type variables,+ -- and a set of constructors. (The variables might already be+ -- instantiated to actual types.) deriving (Show) instance Eq HType where@@ -49,7 +49,7 @@ (Tuple xs) == (Tuple ys) = xs==ys (Prim x _) == (Prim y _) = x==y String == String = True- (Defined n _xs _) == (Defined m _ys _) = n==m -- && xs==ys+ (Defined n _xs _) == (Defined m _ys _) = n==m -- && xs==ys _ == _ = False -- | A concrete representation of any user-defined Haskell constructor.@@ -202,11 +202,11 @@ DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht]))) where macrosFirst :: [MarkupDecl] -> [MarkupDecl]- macrosFirst decls = concat [p, p'] where (p, p') = partition f decls- f (Entity _) = True- f _ = False+ macrosFirst decls = p ++ p' where (p, p') = partition f decls+ f (Entity _) = True+ f _ = False toplevel ht@(Defined _ _ _) = N $ showHType ht "-XML"- toplevel ht@_ = N $ showHType ht ""+ toplevel ht = N $ showHType ht "" c0 = False h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl] -- toplevel? history history remainingwork result@@ -238,7 +238,7 @@ declConstr chist c@(Constr s fv hts) | c `notElem` chist = [Element (ElementDecl (N $ flatConstr c "") (ContentSpec (constrHtExpr c)))]- | otherwise = [] + | otherwise = [] declprim (Prim _ t) = [ Element (ElementDecl (N t) EMPTY) , AttList (AttListDecl (N t) [AttDef (N "value") StringType REQUIRED])]@@ -261,13 +261,13 @@ showHType (Prim _ t) = showString t showHType String = showString "string" showHType (Defined s fv _)- = showString s . ((length fv > 0) ? (showChar '-'))+ = showString s . ((length fv > 0) ? showChar '-') . foldr (.) id (intersperse (showChar '-') (map showHType fv)) flatConstr :: Constr -> ShowS flatConstr (Constr s fv _)- = showString s . ((length fv > 0) ? (showChar '-'))+ = showString s . ((length fv > 0) ? showChar '-') . foldr (.) id (intersperse (showChar '-') (map showHType fv)) outerHtExpr :: HType -> CP@@ -279,7 +279,7 @@ innerHtExpr :: HType -> Modifier -> CP innerHtExpr (Prim _ t) m = TagName (N t) m-innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m+innerHtExpr (Tuple hts) m = Seq (map (`innerHtExpr` None) hts) m innerHtExpr ht@(Defined _ _ _) m = -- CPPE (showHType ht "") (outerHtExpr ht) TagName (N ('%': showHType ht ";")) m -- ***HACK!!!***
src/Text/XML/HaXml/Types.hs view
@@ -133,14 +133,14 @@ -- | The symbol table stored in a document holds all its general entity -- reference definitions. data Document i = Document Prolog (SymTab EntityDef) (Element i) [Misc]- deriving Eq+ deriving (Eq, Show) data Prolog = Prolog (Maybe XMLDecl) [Misc] (Maybe DocTypeDecl) [Misc]- deriving Eq+ deriving (Eq, Show) data XMLDecl = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl)- deriving Eq+ deriving (Eq, Show) data Misc = Comment Comment | PI ProcessingInstruction- deriving Eq+ deriving (Eq, Show) type ProcessingInstruction = (PITarget,String) @@ -149,20 +149,20 @@ type Comment = String type PITarget = String -data DocTypeDecl = DTD QName (Maybe ExternalID) [MarkupDecl] deriving Eq+data DocTypeDecl = DTD QName (Maybe ExternalID) [MarkupDecl] deriving (Eq, Show) data MarkupDecl = Element ElementDecl | AttList AttListDecl | Entity EntityDecl | Notation NotationDecl | MarkupMisc Misc- deriving Eq+ deriving (Eq, Show) -data ExtSubset = ExtSubset (Maybe TextDecl) [ExtSubsetDecl] deriving Eq+data ExtSubset = ExtSubset (Maybe TextDecl) [ExtSubsetDecl] deriving (Eq, Show) data ExtSubsetDecl = ExtMarkupDecl MarkupDecl | ExtConditionalSect ConditionalSect- deriving Eq+ deriving (Eq, Show) -data Element i = Elem QName [Attribute] [Content i] deriving Eq+data Element i = Elem QName [Attribute] [Content i] deriving (Eq, Show) -- ElemTag is an intermediate type for parsing only data ElemTag = ElemTag QName [Attribute] type Attribute = (QName, AttValue)@@ -171,6 +171,7 @@ -- ^ bool is whether whitespace is significant | CRef Reference i | CMisc Misc i+ deriving Show -- custom instance of Eq, ignoring the informational elements. instance Eq (Content i) where@@ -195,30 +196,30 @@ fmap f (CRef r i) = CRef r (f i) fmap f (CMisc m i) = CMisc m (f i) -data ElementDecl = ElementDecl QName ContentSpec deriving Eq+data ElementDecl = ElementDecl QName ContentSpec deriving (Eq, Show) data ContentSpec = EMPTY | ANY | Mixed Mixed | ContentSpec CP- deriving Eq+ deriving (Eq, Show) data CP = TagName QName Modifier | Choice [CP] Modifier | Seq [CP] Modifier- deriving Eq+ deriving (Eq, Show) data Modifier = None -- ^ Just One | Query -- ^ Zero Or One | Star -- ^ Zero Or More | Plus -- ^ One Or More- deriving Eq+ deriving (Eq, Show) data Mixed = PCDATA | PCDATAplus [QName]- deriving Eq-data AttListDecl = AttListDecl QName [AttDef] deriving Eq-data AttDef = AttDef QName AttType DefaultDecl deriving Eq+ deriving (Eq, Show)+data AttListDecl = AttListDecl QName [AttDef] deriving (Eq, Show)+data AttDef = AttDef QName AttType DefaultDecl deriving (Eq, Show) data AttType = StringType | TokenizedType TokenizedType | EnumeratedType EnumeratedType- deriving Eq+ deriving (Eq, Show) data TokenizedType = ID | IDREF | IDREFS@@ -226,25 +227,25 @@ | ENTITIES | NMTOKEN | NMTOKENS- deriving Eq+ deriving (Eq, Show) data EnumeratedType = NotationType NotationType | Enumeration Enumeration- deriving Eq+ deriving (Eq, Show) type NotationType = [Name] -- nonempty list type Enumeration = [NmToken] -- nonempty list data DefaultDecl = REQUIRED | IMPLIED | DefaultTo AttValue (Maybe FIXED)- deriving Eq-data FIXED = FIXED deriving Eq+ deriving (Eq, Show)+data FIXED = FIXED deriving (Eq, Show) data ConditionalSect = IncludeSect IncludeSect | IgnoreSect IgnoreSect- deriving Eq+ deriving (Eq, Show) type IncludeSect = [ExtSubsetDecl] type IgnoreSect = [IgnoreSectContents]-data Ignore = Ignore deriving Eq-data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)] deriving Eq+data Ignore = Ignore deriving (Eq, Show)+data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)] deriving (Eq, Show) data Reference = RefEntity EntityRef | RefChar CharRef@@ -255,25 +256,25 @@ data EntityDecl = EntityGEDecl GEDecl | EntityPEDecl PEDecl- deriving Eq-data GEDecl = GEDecl Name EntityDef deriving Eq-data PEDecl = PEDecl Name PEDef deriving Eq+ deriving (Eq, Show)+data GEDecl = GEDecl Name EntityDef deriving (Eq, Show)+data PEDecl = PEDecl Name PEDef deriving (Eq, Show) data EntityDef = DefEntityValue EntityValue | DefExternalID ExternalID (Maybe NDataDecl)- deriving Eq+ deriving (Eq, Show) data PEDef = PEDefEntityValue EntityValue | PEDefExternalID ExternalID deriving (Eq,Show) data ExternalID = SYSTEM SystemLiteral | PUBLIC PubidLiteral SystemLiteral deriving (Eq,Show)-newtype NDataDecl = NDATA Name deriving Eq+newtype NDataDecl = NDATA Name deriving (Eq, Show) -data TextDecl = TextDecl (Maybe VersionInfo) EncodingDecl deriving Eq-data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving Eq-data ExtPE = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving Eq+data TextDecl = TextDecl (Maybe VersionInfo) EncodingDecl deriving (Eq, Show)+data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving (Eq, Show)+data ExtPE = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving (Eq, Show) -data NotationDecl = NOTATION Name (Either ExternalID PublicID) deriving Eq-newtype PublicID = PUBLICID PubidLiteral deriving Eq-newtype EncodingDecl = EncodingDecl String deriving Eq+data NotationDecl = NOTATION Name (Either ExternalID PublicID) deriving (Eq, Show)+newtype PublicID = PUBLICID PubidLiteral deriving (Eq, Show)+newtype EncodingDecl = EncodingDecl String deriving (Eq, Show) -- | A QName is a (possibly) qualified name, in the sense of XML namespaces. data QName = N Name
src/Text/XML/HaXml/Validate.hs view
@@ -11,7 +11,7 @@ import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o) import Text.XML.HaXml.XmlContent (attr2str) import Data.Maybe (fromMaybe,isNothing,fromJust)-import Data.List (intersperse,nub,(\\))+import Data.List (intercalate,nub,(\\)) import Data.Char (isSpace) #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)@@ -36,11 +36,11 @@ -- gather appropriate information out of the DTD data SimpleDTD = SimpleDTD- { elements :: FiniteMap QName ContentSpec -- content model of elem+ { elements :: FiniteMap QName ContentSpec -- content model of elem , attributes :: FiniteMap (QName,QName) AttType -- type of (elem,attr)- , required :: FiniteMap QName [QName] -- required attributes of elem- , ids :: [(QName,QName)] -- all (element,attr) with ID type- , idrefs :: [(QName,QName)] -- all (element,attr) with IDREF type+ , required :: FiniteMap QName [QName] -- required attributes of elem+ , ids :: [(QName,QName)] -- all (element,attr) with ID type+ , idrefs :: [(QName,QName)] -- all (element,attr) with IDREF type } simplifyDTD :: DocTypeDecl -> SimpleDTD@@ -67,7 +67,7 @@ , AttList (AttListDecl name attdefs) <- decls , elem == name , AttDef attr (TokenizedType ID) _ <- attdefs ]- , idrefs = [] -- not implemented+ , idrefs = [] -- not implemented } -- simple auxiliary to avoid lots of if-then-else with empty else clauses.@@ -97,13 +97,13 @@ valid (Elem name attrs contents) = -- is the element defined in the DTD?- let spec = lookupFM (elements dtd) name in - (isNothing spec) `gives` ("Element <"++qname name++"> not known.")+ let spec = lookupFM (elements dtd) name in+ isNothing spec `gives` ("Element <"++qname name++"> not known.") -- is each attribute mentioned only once? ++ (let dups = duplicates (map (qname . fst) attrs) in not (null dups) `gives` ("Element <"++qname name++"> has duplicate attributes: "- ++concat (intersperse "," dups)++"."))+ ++intercalate "," dups++".")) -- does each attribute belong to this element? value is in range? ++ concatMap (checkAttr name) attrs -- are all required attributes present?@@ -124,7 +124,7 @@ EnumeratedType e -> case e of Enumeration es ->- (not (attval `Prelude.elem` es)) `gives`+ (attval `notElem` es) `gives` ("Value \""++attval++"\" of attribute \"" ++qname attr++"\" in element <"++qname elm ++"> is not in the required enumeration range: "@@ -133,7 +133,7 @@ _ -> [] checkRequired elm attrs req =- (not (req `Prelude.elem` map fst attrs)) `gives`+ (req `notElem` map fst attrs) `gives` ("Element <"++qname elm++"> requires the attribute \""++qname req ++"\" but it is missing.") @@ -151,7 +151,7 @@ ++"elements beyond its content spec."]) checkMixed elm permitted (CElem (Elem name _ _) _)- | not (name `Prelude.elem` permitted) =+ | name `notElem` permitted = ["Element <"++qname elm++"> contains an element <"++qname name ++"> but should not."] checkMixed _elm _permitted _ = []@@ -191,7 +191,7 @@ checkCP elm cp@(Choice cps None) ns = let next = choice elm ns cps in if null next then (cpError elm cp, ns)- else ([], head next) -- choose the first alternative with no errors+ else ([], head next) -- choose the first alternative with no errors checkCP _ (Choice _ Query) [] = ([],[]) checkCP elm (Choice cps Query) ns = let next = choice elm ns cps in@@ -260,7 +260,7 @@ badIds = duplicates (map (\(CString _ s _)->s) idElems) in not (null badIds) `gives` ("These attribute values of type ID are not unique: "- ++concat (intersperse "," badIds)++".")+ ++intercalate "," badIds++".") cpError :: QName -> CP -> [String]@@ -270,9 +270,9 @@ display :: CP -> String display (TagName name mod) = qname name ++ modifier mod-display (Choice cps mod) = "(" ++ concat (intersperse "|" (map display cps))+display (Choice cps mod) = "(" ++ intercalate "|" (map display cps) ++ ")" ++ modifier mod-display (Seq cps mod) = "(" ++ concat (intersperse "," (map display cps))+display (Seq cps mod) = "(" ++ intercalate "," (map display cps) ++ ")" ++ modifier mod modifier :: Modifier -> String@@ -282,7 +282,7 @@ modifier Plus = "+" duplicates :: Eq a => [a] -> [a]-duplicates xs = xs \\ (nub xs)+duplicates xs = xs \\ nub xs qname :: QName -> String qname n = printableName n
src/Text/XML/HaXml/Verbatim.hs view
@@ -58,7 +58,7 @@ verbatim :: a -> String instance (Verbatim a) => Verbatim [a] where- verbatim = concat . (map verbatim)+ verbatim = concatMap verbatim instance Verbatim Char where verbatim c = [c]@@ -77,10 +77,10 @@ instance Verbatim (Element i) where verbatim (Elem nam att []) = "<" ++ qname nam- ++ (concat . (map verbAttr)) att+ ++ concatMap verbAttr att ++ "/>" verbatim (Elem nam att cont) = "<" ++ qname nam- ++ (concat . (map verbAttr)) att+ ++ concatMap verbAttr att ++ ">" ++ verbatim cont ++ "</" ++ qname nam ++ ">" @@ -99,4 +99,3 @@ verbAttr :: Attribute -> String verbAttr (n, AttValue v) = " " ++ qname n ++ "=\"" ++ verbatim v ++ "\""-
+ src/Text/XML/HaXml/Version.hs view
@@ -0,0 +1,6 @@+module Text.XML.HaXml.Version+ ( version+ ) where++version :: String+version = "1.25.6"
src/Text/XML/HaXml/Wrappers.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#define dummy -- just to ensure that cpp gets called on this file+#define dummy -- just to ensure that cpp gets called on this file module Text.XML.HaXml.Wrappers ( fix2Args , processXmlWith@@ -20,6 +20,7 @@ import Text.XML.HaXml.Parse (xmlParse) import Text.XML.HaXml.Html.Parse (htmlParse) import Text.XML.HaXml.Pretty as PP(document)+import Text.XML.HaXml.Version import Text.PrettyPrint.HughesPJ (render) @@ -31,11 +32,11 @@ fix2Args = do args <- getArgs when ("--version" `elem` args) $ do- putStrLn $ "part of HaXml-"++show MAJOR.MINOR- exitWith ExitSuccess+ putStrLn $ "part of HaXml-" ++ version+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://projects.haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -65,7 +66,7 @@ hFlush o where- onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn+ onContent :: FilePath -> CFilter Posn -> Document Posn -> Document Posn onContent file filter (Document p s e m) = case filter (CElem e (posInNewCxt file Nothing)) of [CElem e' _] -> Document p s e' m
src/Text/XML/HaXml/XmlContent.hs view
@@ -4,7 +4,7 @@ -- -- If you are starting with an XML DTD, use HaXml's tool DtdToHaskell -- to generate both the Haskell types and the corresponding instances.--- +-- -- If you are starting with a set of Haskell datatypes, use DrIFT to -- derive instances of this class for you: -- http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT@@ -168,7 +168,7 @@ parseContents = let result = runParser p [] -- for type of result only p = case (toHType . head . (\ (Right x)->x) . fst) result of- (Prim "Char" _) -> fmap (map xFromChar) $ text+ (Prim "Char" _) -> map xFromChar <$> text _ -> many parseContents in p -- comments, PIs, etc, are skipped in the individual element parser.
src/Text/XML/HaXml/XmlContent/Haskell.hs view
@@ -175,7 +175,7 @@ instance XmlContent Char where -- NOT in a string toContents c = [CElem (Elem (N "char") [mkAttr "value" [c]] []) ()]- parseContents = do { (Elem _ [(N "value",(AttValue [Left [c]]))] [])+ parseContents = do { (Elem _ [(N "value",AttValue [Left [c]])] []) <- element ["char"] ; return c }@@ -216,7 +216,7 @@ (CRef r pos: cs) -> Failure cs ("Expected a <list-...>, but found a ref " ++verbatim r++" at\n"++ show pos)- (_:cs) -> ((\ (P p)-> p) parseContents) cs -- skip comments etc.+ (_:cs) -> (\ (P p)-> p) parseContents cs -- skip comments etc. [] -> Failure [] "Ran out of input XML whilst secondary parsing" ) @@ -239,9 +239,9 @@ toContents v@(Right ab) = [mkElemC (showConstr 1 (toHType v)) (toContents ab)] parseContents =- (inElementWith (flip isPrefixOf) "Left" $ fmap Left parseContents)+ inElementWith (flip isPrefixOf) "Left" (fmap Left parseContents) `onFail`- (inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents)+ inElementWith (flip isPrefixOf) "Right" (fmap Right parseContents) -- do{ e@(Elem t [] _) <- element ["Left","Right"] -- ; case t of
src/Text/XML/HaXml/XmlContent/Parser.hs view
@@ -13,7 +13,7 @@ -- This unified class interface replaces two previous (somewhat similar) -- classes: Haskell2Xml and Xml2Haskell. There was no real reason to have -- separate classes depending on how you originally defined your datatypes.--- However, some instances for basic types like lists will depend on which +-- However, some instances for basic types like lists will depend on which -- direction you are using. See Text.XML.HaXml.XmlContent and -- Text.XML.HaXml.XmlContent.Haskell. @@ -67,7 +67,7 @@ , ANYContent(..) ) where ---import System.IO+import Control.Monad (void) import Data.Maybe (catMaybes) import Data.Char (chr, isSpace) @@ -609,7 +609,7 @@ str2attr :: String -> AttValue str2attr s = let f t =- let (l,r) = span (\c-> not (elem c "\"&<>'")) t+ let (l,r) = span (`notElem` "\"&<>'") t in if null r then [Left l] else Left l: Right (g (head r)): f (tail r) g '"' = RefEntity "quot"@@ -652,8 +652,8 @@ | UnConverted [Content Posn] instance Show ANYContent where- show (UnConverted c) = "UnConverted " ++ (show $ map verbatim c)- show (ANYContent a) = "ANYContent " ++ (show a)+ show (UnConverted c) = "UnConverted " ++ show (map verbatim c)+ show (ANYContent a) = "ANYContent " ++ show a instance Eq ANYContent where a == b = show a == show b@@ -673,14 +673,14 @@ hx = toHType x instance (XmlContent a) => XmlContent (List1 a) where toContents (NonEmpty xs) = concatMap toContents xs- parseContents = fmap NonEmpty $ many1 parseContents+ parseContents = NonEmpty <$> many1 parseContents instance HTypeable ANYContent where toHType _ = Prim "ANYContent" "ANY" instance XmlContent ANYContent where toContents (ANYContent a) = toContents a- toContents (UnConverted s) = map (fmap (const ())) s- parseContents = P (\cs -> Success [] (UnConverted cs))+ toContents (UnConverted s) = map void s+ parseContents = P (Success [] . UnConverted) ------------------------------------------------------------------------ --
src/Text/XML/HaXml/Xtract/Combinators.hs view
@@ -21,20 +21,20 @@ -- | lift an ordinary content filter to a double filter. local,global :: CFilter i -> DFilter i-local f = \_xml sub-> f sub-global f = \ xml _sub-> f xml+local f _xml sub = f sub+global f xml _sub = f xml -- | drop a double filter to an ordinary content filter. -- (permitting interior access to document root) dfilter :: DFilter i -> CFilter i-dfilter f = \xml-> f xml xml+dfilter f xml = f xml xml -- | drop a double filter to an ordinary content filter. -- (Where interior access to the document root is not needed, the -- retaining pointer to the outer element can be pruned away. -- 'cfilter' is more space-efficient than 'dfilter' in this situation.) cfilter :: DFilter i -> CFilter i-cfilter f = \xml -> f undefined xml+cfilter f = f undefined --cfilter f = \xml-> flip f xml -- (case xml of -- CElem (Elem n as cs) i -> CElem (Elem n [] []) i@@ -42,12 +42,12 @@ -- | lift a CFilter combinator to a DFilter combinator liftLocal, liftGlobal :: (CFilter i->CFilter i) -> (DFilter i->DFilter i)-liftLocal ff = \df-> \xml sub-> (ff (df xml)) sub-liftGlobal ff = \df-> \xml _sub-> (ff (df xml)) xml+liftLocal ff df xml sub = ff (df xml) sub+liftGlobal ff df xml _sub = ff (df xml) xml -- | lifted composition over double filters. o :: DFilter i -> DFilter i -> DFilter i-g `o` f = \xml-> concatMap (g xml) . (f xml)+g `o` f = \xml-> concatMap (g xml) . f xml -- | lifted choice. (|>|) :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])@@ -58,7 +58,7 @@ union :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c]) union = lift (++) where- lift f g h = \x y-> f (g x y) (h x y)+ lift f g h x y = f (g x y) (h x y) -- | lifted predicates. with, without :: DFilter i -> DFilter i -> DFilter i@@ -67,8 +67,8 @@ -- | lifted unit and zero. keep, none :: DFilter i-keep = \_xml sub-> [sub] -- local C.keep-none = \_xml _sub-> [] -- local C.none+keep _xml sub = [sub] -- local C.keep+none _xml _sub = [] -- local C.none children, elm, txt :: DFilter i children = local C.children@@ -76,11 +76,11 @@ txt = local C.txt applypred :: CFilter i -> DFilter i -> CFilter i-applypred f p = \xml-> (const f `with` p) xml xml+applypred f p xml = (const f `with` p) xml xml iffind :: String -> (String -> DFilter i) -> DFilter i -> DFilter i iffind key yes no xml c@(CElem (Elem _ as _) _) =- case (lookup (N key) as) of+ case lookup (N key) as of Nothing -> no xml c (Just v@(AttValue _)) -> yes (show v) xml c iffind _key _yes no xml other = no xml other@@ -90,7 +90,7 @@ ifTxt _yes no xml c = no xml c cat :: [a->b->[c]] -> (a->b->[c])-cat fs = \xml sub-> concat [ f xml sub | f <- fs ]+cat fs xml sub = concat [ f xml sub | f <- fs ] (/>) :: DFilter i -> DFilter i -> DFilter i f /> g = g `o` children `o` f
src/Text/XML/HaXml/Xtract/Lex.hs view
@@ -18,7 +18,7 @@ type Token = Either String (Posn, TokenT) -data Posn = Pn Int -- char index only+data Posn = Pn Int -- char index only deriving Eq instance Show Posn where@@ -26,8 +26,8 @@ data TokenT = Symbol String- | TokString String -- begins with letter- | TokNum Integer -- begins with digit+ | TokString String -- begins with letter+ | TokNum Integer -- begins with digit deriving Eq instance Show TokenT where
src/Text/XML/HaXml/Xtract/Parse.hs view
@@ -79,76 +79,76 @@ {--- original Xtract grammar ----- query = string tagname- | string * tagname prefix- | * string tagname suffix- | * any element- | - chardata+ query = string tagname+ | string * tagname prefix+ | * string tagname suffix+ | * any element+ | - chardata | ( query )- | query / query parent/child relationship- | query // query deep inside- | query + query union of queries+ | query / query parent/child relationship+ | query // query deep inside+ | query + query union of queries | query [predicate] | query [positions] - predicate = quattr has attribute- | quattr op ' string ' attribute has value- | quattr op " string " attribute has value- | quattr op quattr attribute value comparison (lexical)- | quattr nop integer attribute has value (numerical)- | quattr nop quattr attribute value comparison (numerical)- | ( predicate ) bracketting- | predicate & predicate logical and- | predicate | predicate logical or- | ~ predicate logical not+ predicate = quattr has attribute+ | quattr op ' string ' attribute has value+ | quattr op " string " attribute has value+ | quattr op quattr attribute value comparison (lexical)+ | quattr nop integer attribute has value (numerical)+ | quattr nop quattr attribute value comparison (numerical)+ | ( predicate ) bracketting+ | predicate & predicate logical and+ | predicate | predicate logical or+ | ~ predicate logical not - attribute = @ string has attribute- | query / @ string child has attribute- | - has textual content- | query / - child has textual content+ attribute = @ string has attribute+ | query / @ string child has attribute+ | - has textual content+ | query / - child has textual content quattr = query | attribute - op = = equal to- | != not equal to- | < less than- | <= less than or equal to- | > greater than- | >= greater than or equal to+ op = = equal to+ | != not equal to+ | < less than+ | <= less than or equal to+ | > greater than+ | >= greater than or equal to - nop = .=. equal to- | .!=. not equal to- | .<. less than- | .<=. less than or equal to- | .>. greater than- | .>=. greater than or equal to+ nop = .=. equal to+ | .!=. not equal to+ | .<. less than+ | .<=. less than or equal to+ | .>. greater than+ | .>=. greater than or equal to - positions = position {, positions} multiple positions- | position - position ranges+ positions = position {, positions} multiple positions+ | position - position ranges - position = integer numbering is from 0 upwards- | $ last+ position = integer numbering is from 0 upwards+ | $ last ---- transformed grammar (removing left recursion)- aquery = ./ tquery -- current context- | tquery -- also current context- | / tquery -- root context- | // tquery -- deep context from root+ aquery = ./ tquery -- current context+ | tquery -- also current context+ | / tquery -- root context+ | // tquery -- deep context from root tquery = ( tquery ) xquery | tag xquery- | - -- fixes original grammar ("-/*" is incorrect)- + | - -- fixes original grammar ("-/*" is incorrect)+ tag = string * | string | * string | *- + xquery = / tquery | // tquery- | / @ string -- new: print attribute value+ | / @ string -- new: print attribute value | + tquery | [ tpredicate ] xquery | [ positions ] xquery@@ -228,7 +228,7 @@ [ do q <- bracket (tquery (qf:qf:cxt)) xquery cxt q , do q <- xtag- xquery cxt (qf ((unescape .).q)) -- glue inners texts together+ xquery cxt (qf ((unescape .).q)) -- glue inners texts together , do symbol "-" return (qf (local C.txt)) ]@@ -238,11 +238,10 @@ [ do s <- string symbol "*" return (local (C.tagWith (s `isPrefixOf`)))- , do s <- string- return (local (C.tag s))+ , local . C.tag <$> string , do symbol "*" s <- string- return (local (C.tagWith (((reverse s) `isPrefixOf`) . reverse)))+ return (local (C.tagWith ((reverse s `isPrefixOf`) . reverse))) , do symbol "*" return (local C.elm) ]@@ -251,19 +250,19 @@ xquery :: [DFilter i->DFilter i] -> DFilter i -> XParser (DFilter i) xquery cxt q1 = oneOf [ do symbol "/"- ( do symbol "@"- attr <- string- return (D.iffind attr (\s->local (C.literal s)) D.none `D.o` q1)+ do symbol "@"+ attr <- string+ return (D.iffind attr (local . C.literal) D.none `D.o` q1) `onFail`- tquery ((q1 D./>):cxt) )+ tquery ((q1 D./>):cxt) , do symbol "//"- tquery ((\q2-> (liftLocal C.multi) q2+ tquery ((\q2-> liftLocal C.multi q2 `D.o` local C.children `D.o` q1):cxt) , do symbol "+" q2 <- tquery cxt return (D.cat [q1,q2]) , do symbol "["- is <- iindex -- now extended to multiple indexes+ is <- iindex -- now extended to multiple indexes symbol "]" xquery cxt (\xml-> concat . pam is . q1 xml) , do symbol "["@@ -324,24 +323,24 @@ quote s2 <- string quote- return ((iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none)+ return (iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none `D.o` q) , do cmp <- op- (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?- return ((iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none)+ (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?+ return (iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none) D.none)- D.none) `D.o` q)+ D.none `D.o` q) , do cmp <- nop n <- number- return ((iffn (\s->if cmp (read s) n then D.keep else D.none) D.none)+ return (iffn (\s->if cmp (read s) n then D.keep else D.none) D.none `D.o` q) , do cmp <- nop- (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?- return ((iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep+ (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?+ return (iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep else D.none) D.none)- D.none) `D.o` q)- , do return ((a `D.o` q))+ D.none `D.o` q)+ , do return (a `D.o` q) ] wattribute :: XParser (DFilter i, (String->DFilter i)->DFilter i->DFilter i)@@ -368,8 +367,7 @@ simpleindex :: XParser ([a]->[a]) simpleindex = oneOf [ do n <- number- r <- rrange n- return r+ rrange n , do symbol "$" return (C.keep . last) ]@@ -417,4 +415,3 @@ , do symbol ".>."; return (>) , do symbol ".>=."; return (>=) ]-
src/tools/DtdToHaskell.hs view
@@ -9,7 +9,7 @@ import System.Environment import System.Exit import System.IO-import Data.List (nub,takeWhile,dropWhile)+import Data.List (nub) import Control.Monad --import Text.XML.HaXml.Wrappers (fix2Args)@@ -17,21 +17,21 @@ import Text.XML.HaXml.Types (DocTypeDecl(..)) import Text.XML.HaXml.Namespaces (localName) import Text.XML.HaXml.Parse (dtdParse)-import Text.XML.HaXml.DtdToHaskell.TypeDef (TypeDef,ppTypeDef,mangle)+import Text.XML.HaXml.DtdToHaskell.TypeDef (ppTypeDef,mangle) import Text.XML.HaXml.DtdToHaskell.Convert (dtd2TypeDef) import Text.XML.HaXml.DtdToHaskell.Instance (mkInstance) import Text.PrettyPrint.HughesPJ (render,vcat) --- sucked in from Text.XML.HaXml.Wrappers to avod dependency on T.X.H.Html+-- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html fix2Args :: IO (String,String) fix2Args = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -50,9 +50,10 @@ else openFile outf WriteMode ) >>= \o-> let (DTD name _ markup) = (getDtd . dtdParse inf) content decls = (nub . dtd2TypeDef) markup- realname = if outf/="-" then mangle (trim outf)- else if null (localName name) then mangle (trim inf)- else mangle (localName name)+ realname+ | outf /= "-" = mangle (trim outf)+ | null (localName name) = mangle (trim inf)+ | otherwise = mangle (localName name) in do hPutStrLn o ("module "++realname ++" where\n\nimport Text.XML.HaXml.XmlContent"@@ -69,10 +70,9 @@ getDtd :: Maybe t -> t getDtd (Just dtd) = dtd-getDtd (Nothing) = error "No DTD in this document"+getDtd Nothing = error "No DTD in this document" trim :: [Char] -> [Char] trim name | '/' `elem` name = (trim . tail . dropWhile (/='/')) name | '.' `elem` name = takeWhile (/='.') name | otherwise = name-
src/tools/FpMLToHaskell.hs view
@@ -12,12 +12,11 @@ import System.Environment import System.IO import Control.Monad+import Control.Exception as E import System.Directory import Data.List-import Data.Maybe (fromMaybe,catMaybes)+import Data.Maybe (fromMaybe,mapMaybe) import Data.Function (on)-import Data.Monoid (mconcat)---import Either import Text.XML.HaXml (version) import Text.XML.HaXml.Types@@ -36,7 +35,7 @@ import qualified Text.XML.HaXml.Schema.PrettyHsBoot as HsBoot import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell import Text.ParserCombinators.Poly-import Text.PrettyPrint.HughesPJ (render,vcat)+import Text.PrettyPrint.HughesPJ (render) fst3 :: (a,b,c) -> a fst3 (a,_,_) = a@@ -47,12 +46,12 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "Usage: FpMLToHaskell xsdDir haskellDir"- putStrLn $ " -- The results go into haskelldir/Data/FpML/file0.hs etc"- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "Usage: FpMLToHaskell xsdDir haskellDir"+ putStrLn " -- The results go into haskelldir/Data/FpML/file0.hs etc"+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case args of [xsddir,hdir]-> do files <- fmap (filter (".xsd" `isSuffixOf`))@@ -60,22 +59,22 @@ let newdirs = map (\file->hdir++"/"++dirOf (fpml file)) files mapM_ (\newdir -> do createDirectoryIfMissing True newdir) newdirs return (xsddir- ,map (\f-> (f, hdir++"/"++(reslash (fpml f))++".hs")) files)+ ,map (\f-> (f, hdir++"/"++reslash (fpml f)++".hs")) files) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" xsdDir haskellDir") exitFailure where reslash = map (\c-> case c of '.'->'/'; _->c)- dirOf = concat . intersperse "/" . init . wordsBy '.'- wordsBy c s = let (a,b) = span (/=c) s in- if null b then [a] else a: wordsBy c (tail b)+ dirOf = intercalate "/" . init . wordsBy' '.'+ wordsBy' c s = let (a,b) = span (/=c) s in+ if null b then [a] else a: wordsBy' c (tail b) main ::IO () main = do (dir,files) <- argDirsToFiles- deps <- flip mapM files (\ (inf,outf)-> do- hPutStrLn stdout $ "Reading "++inf- thiscontent <- readFile (dir++"/"++inf)+ deps <- forM files (\ (inf,_outf)-> do+ putStrLn $ "Reading "++inf+ thiscontent <- readFileUTF8 (dir++"/"++inf) let d@Document{} = resolveAllNames qualify . either (error . ("not XML:\n"++)) id . xmlParse' inf@@ -84,11 +83,11 @@ (Left msg,_) -> do hPutStrLn stderr msg return ([], undefined) (Right v,[]) -> return (Env.gatherImports v, v)- (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"- hPutStrLn stdout $ inf- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ (Right v,_) -> do putStrLn "Parse incomplete!"+ putStrLn inf+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" return ([],v) ) let filedeps :: [[((FilePath,FilePath),([(FilePath,Maybe String)],Schema))]]@@ -98,9 +97,9 @@ (zip files deps) -- a single supertype environment, closed over all modules supertypeEnv :: Environment- supertypeEnv = foldr (\fs e->- foldr (\((inf,_),(_,v))-> mkEnvironment inf v)- e fs)+ supertypeEnv = foldr (flip (foldr+ (\ ((inf, _), (_, v)) ->+ mkEnvironment inf v))) emptyEnv filedeps adjust :: Environment -> Environment adjust env = env{ env_extendty = env_extendty supertypeEnv@@ -136,24 +135,24 @@ (\d-> fst3 $ fromMaybe (error "FME") $ lookup d environs)- in flip map cyclic- (\((inf,outf),(_,v))->- (inf,(adjust $ mkEnvironment inf v- $ jointEnv- ,outf- ,v)- )- )- flip mapM_ environs (\ (inf,(env,outf,v))-> do+ in flip map cyclic $+ \((inf,outf),(_,v))->+ (inf,(adjust $ mkEnvironment inf v jointEnv+ ,outf+ ,v)+ )+ forM_ environs (\ (inf,(env,outf,v))-> do o <- openFile outf WriteMode hb <- openFile (bootf outf) WriteMode- let decls = XsdToH.convert env v+ hSetEncoding o utf8+ hSetEncoding hb utf8+ let decls = XsdToH.convert env (XsdToH.typeLift v) haskell = Haskell.mkModule inf v decls doc = ppModule fpmlNameConverter haskell docboot = HsBoot.ppModule fpmlNameConverter haskell- hPutStrLn stdout $ "Writing "++outf+ putStrLn $ "Writing "++outf hPutStrLn o $ render doc- hPutStrLn stdout $ "Writing "++(bootf outf)+ putStrLn $ "Writing "++bootf outf hPutStrLn hb $ render docboot hFlush o hFlush hb@@ -168,36 +167,36 @@ -- | Calculate dependency ordering of modules, least dependent first. -- Cyclic groups may occur, suitably placed in the ordering. ordered :: (Eq a, Eq b) => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]]-ordered name deps env list =- let cycles = cyclicDeps name deps env list+ordered name' deps env list =+ let cycles = cyclicDeps name' deps env list noncyclic = map (:[]) $ list \\ concat cycles workqueue = noncyclic++cycles- in traverse [] workqueue+ in traverse' [] workqueue where- traverse acc [] = acc- traverse acc (w:wq) = if all (`elem` concatMap (map name) acc)- (concatMap deps w \\ map name w)- then traverse (acc++[w]) wq- else traverse acc (wq++[w])+ traverse' acc [] = acc+ traverse' acc (w:wq) = if all (`elem` concatMap (map name') acc)+ (concatMap deps w \\ map name' w)+ then traverse' (acc++[w]) wq+ else traverse' acc (wq++[w]) -- | Find cyclic dependencies between modules. cyclicDeps :: Eq a => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]]-cyclicDeps name deps env = nubBy (setEq`on`map name)+cyclicDeps name' deps env = nubBy (setEq`on`map name') . (\cs-> foldl minimal cs cs) . concatMap (walk []) where -- walk :: [b] -> b -> [[b]]- walk acc t = if name t `elem` map name acc then [acc]- else concatMap (walk (t:acc)) (catMaybes . map env $ deps t)+ walk acc t = if name' t `elem` map name' acc then [acc]+ else concatMap (walk (t:acc)) (mapMaybe env $ deps t) minimal acc c = concatMap (prune c) acc- prune c c' = if map name c `isProperSubsetOf` map name c' then [] else [c']+ prune c c' = [c' | not (map name' c `isProperSubsetOf` map name' c')] isSubsetOf a b = all (`elem`b) a setEq a b = a`isSubsetOf`b && b`isSubsetOf`a isProperSubsetOf a b = a`isSubsetOf`b && not (b`isSubsetOf`a) -- | A variation on the standard lookup function. lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b-lookupWith proj x [] = Nothing+lookupWith _ _ [] = Nothing lookupWith proj x (y:ys) | proj y == x = Just y | otherwise = lookupWith proj x ys @@ -205,12 +204,17 @@ targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"- else case lookup (N "targetNamespace") attrs of- Nothing -> "ERROR! no targetNamespace specified"- Just atv -> show atv+ else maybe "ERROR! no targetNamespace specified" show+ (lookup (N "targetNamespace") attrs) -- | The XSD Namespace. xsdSchema :: QName xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"}) "schema" +-- | UTF8-clean readFile; avoids handle-leaks.+readFileUTF8 :: FilePath -> IO String+readFileUTF8 file = do+ h <- openFile file ReadMode+ (do hSetEncoding h utf8+ hGetContents h) `E.onException` hClose h
src/tools/MkOneOf.hs view
@@ -1,7 +1,7 @@ module Main where import Prelude hiding (max)-import System.Exit (exitWith,ExitCode(..))+import System.Exit (exitSuccess) import System.Environment (getArgs) import Data.Char (isDigit) import System.IO (hFlush,stdout)@@ -13,19 +13,19 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 1 -> do n <- saferead (head args) putStrLn ("module Text.XML.HaXml."++constructor 1 n++" where\n")- putStrLn ("import Text.XML.HaXml.XmlContent\n")+ putStrLn "import Text.XML.HaXml.XmlContent\n" putStrLn (mkOneOf n) 2 -> do n <- saferead (args!!0) m <- saferead (args!!1)- putStrLn ("module Text.XML.HaXml.OneOfN where\n")- putStrLn ("import Text.XML.HaXml.XmlContent\n")+ putStrLn "module Text.XML.HaXml.OneOfN where\n"+ putStrLn "import Text.XML.HaXml.XmlContent\n" mapM_ (putStrLn . mkOneOf) [n..m] _ -> error "Usage: MkOneOf n [m]" hFlush stdout@@ -74,8 +74,7 @@ constructor n m = ordinal n ++"Of" ++ show m ordinal :: Int -> String-ordinal n | n <= 20 = ordinals!!n-ordinal n | otherwise = "Choice"++show n+ordinal n = if n <= 20 then ordinals!!n else "Choice"++show n ordinals :: [String] ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight"@@ -84,17 +83,17 @@ ---- variable names ---- variables :: [String]-variables = [ v:[] | v <- ['a'..'y']]- ++ [ v:w:[] | v <- ['a'..'z'], w <- ['a'..'z']]+variables = [ [v] | v <- ['a'..'y']]+ ++ [ [v,w] | v <- ['a'..'z'], w <- ['a'..'z']] ---- simple pretty-printing ---- -format :: Int -- current position on page- -> Int -- maximum width of page- -> Int -- amount to indent when a newline is emitted- -> String -- text to precede first value- -> String -- text to precede subsequent values- -> [String] -- list of values to format+format :: Int -- current position on page+ -> Int -- maximum width of page+ -> Int -- amount to indent when a newline is emitted+ -> String -- text to precede first value+ -> String -- text to precede subsequent values+ -> [String] -- list of values to format -> String format _cur _max _ind _s0 _s1 [] = "" format cur max ind s0 s1 (x:xs)@@ -106,6 +105,7 @@ ---- safe integer parsing ---- saferead :: String -> IO Int-saferead s | all isDigit s = return (read s)-saferead s | otherwise = error ("expected a number on the commandline, "- ++"but got \""++s++"\" instead")+saferead s = if all isDigit s+ then return (read s)+ else error ("expected a number on the commandline, "+ ++"but got \""++s++"\" instead")
src/tools/XsdToHaskell.hs view
@@ -29,7 +29,7 @@ import Text.XML.HaXml.Schema.PrettyHaskell import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell import Text.ParserCombinators.Poly-import Text.PrettyPrint.HughesPJ (render,vcat)+import Text.PrettyPrint.HughesPJ (render) -- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html fix2Args :: IO (String,String)@@ -37,10 +37,10 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -64,21 +64,21 @@ in do case runParser schema [docContent (posInNewCxt inf Nothing) d] of (Left msg,_) -> hPutStrLn stderr msg- (Right v,[]) -> do hPutStrLn stdout $ "Parse Success!"- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ (Right v,[]) -> do putStrLn "Parse Success!"+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" let decls = convert (mkEnvironment inf v emptyEnv) v haskl = Haskell.mkModule inf v decls doc = ppModule simpleNameConverter haskl- hPutStrLn stdout $ render doc- (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ hPutStrLn o $ render doc+ (Right v,_) -> do putStrLn "Parse incomplete!"+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" hFlush o - + --do hPutStrLn o $ "Document contains XSD for target namespace "++ -- targetNamespace e {-@@ -115,9 +115,8 @@ targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"- else case lookup (N "targetNamespace") attrs of- Nothing -> "ERROR! no targetNamespace specified"- Just atv -> show atv+ else maybe "ERROR! no targetNamespace specified" show+ (lookup (N "targetNamespace") attrs) xsdSchema :: QName xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"})
src/tools/Xtract.hs view
@@ -1,9 +1,9 @@ ------------------------------------------------------------ -- The Xtract tool - an XML-grep.------------------------------------------------------------- +------------------------------------------------------------ module Main where import System.Environment (getArgs)-import System.Exit (exitWith, ExitCode(..))+import System.Exit (exitWith, exitSuccess, ExitCode(..)) import System.IO import Data.Char (toLower) import Data.List (isSuffixOf)@@ -29,6 +29,7 @@ data Opts = Opts {doEscaping :: Bool, forceHtml :: Bool, printHelp :: Bool, printVersion :: Bool, beLazy :: Bool} +defaultOptions :: Opts defaultOptions = Opts {doEscaping = True, forceHtml = False, printHelp = False, printVersion = False, beLazy = False} options :: [OptDescr (Opts -> Opts)]@@ -48,22 +49,22 @@ main :: IO () main = do preArgs <- getArgs- let (preOpts, args, errs) = getOpt Permute options preArgs+ let (preOpts, args, _errs) = getOpt Permute options preArgs let opts = foldl (flip ($)) defaultOptions preOpts when (printVersion opts) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when (printHelp opts) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess when (length args < 1) $ do putStrLn $ usageInfo "Usage: Xtract [options] <pattern> [xmlfile ...]" options exitWith (ExitFailure 1)- let (xmlParse, htmlParse) = if beLazy opts then - (Text.XML.HaXml.ParseLazy.xmlParse, Text.XML.HaXml.Html.ParseLazy.htmlParse) - else + let (xmlParse, htmlParse) = if beLazy opts then+ (Text.XML.HaXml.ParseLazy.xmlParse, Text.XML.HaXml.Html.ParseLazy.htmlParse)+ else (Text.XML.HaXml.Parse.xmlParse, Text.XML.HaXml.Html.Parse.htmlParse)- let (pattern,files,esc) =+ let (pat,files,esc) = (head args,tail args,if doEscaping opts then escape .(:[]) else (:[])) -- findcontents = -- if null files then (getContents >>= \x-> return [xmlParse "<stdin>"x])@@ -76,11 +77,11 @@ -- . map (vcat . map content . selection . docContent)) cs mapM_ (\x-> do c <- (if x=="-" then getContents else readFile x) ( if isHTML x || forceHtml opts then- hPutStrLn stdout . render . htmlprint- . xtract (map toLower) pattern+ putStrLn . render . htmlprint+ . xtract (map toLower) pat . docContent (posInNewCxt x Nothing) . htmlParse x- else hPutStrLn stdout . render . vcat . map (format . esc)- . xtract id pattern+ else putStrLn . render . vcat . map (format . esc)+ . xtract id pat . docContent (posInNewCxt x Nothing) . xmlParse x) c hFlush stdout) files