diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -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 diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -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 diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,24 +1,39 @@ -name: HaXml -version: 1.23.3 -license: LGPL -license-file: COPYRIGHT -author: Malcolm Wallace -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 +maintainer: Jens Petersen +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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. + +---- diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/src/Text/XML/HaXml.hs b/src/Text/XML/HaXml.hs --- a/src/Text/XML/HaXml.hs +++ b/src/Text/XML/HaXml.hs @@ -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 diff --git a/src/Text/XML/HaXml/ByteStringPP.hs b/src/Text/XML/HaXml/ByteStringPP.hs --- a/src/Text/XML/HaXml/ByteStringPP.hs +++ b/src/Text/XML/HaXml/ByteStringPP.hs @@ -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 diff --git a/src/Text/XML/HaXml/Combinators.hs b/src/Text/XML/HaXml/Combinators.hs --- a/src/Text/XML/HaXml/Combinators.hs +++ b/src/Text/XML/HaXml/Combinators.hs @@ -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 - + {- diff --git a/src/Text/XML/HaXml/DtdToHaskell/Convert.hs b/src/Text/XML/HaXml/DtdToHaskell/Convert.hs --- a/src/Text/XML/HaXml/DtdToHaskell/Convert.hs +++ b/src/Text/XML/HaXml/DtdToHaskell/Convert.hs @@ -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))) - diff --git a/src/Text/XML/HaXml/DtdToHaskell/Instance.hs b/src/Text/XML/HaXml/DtdToHaskell/Instance.hs --- a/src/Text/XML/HaXml/DtdToHaskell/Instance.hs +++ b/src/Text/XML/HaXml/DtdToHaskell/Instance.hs @@ -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 ") ()]") - diff --git a/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs b/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs --- a/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs +++ b/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs @@ -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 diff --git a/src/Text/XML/HaXml/Escape.hs b/src/Text/XML/HaXml/Escape.hs --- a/src/Text/XML/HaXml/Escape.hs +++ b/src/Text/XML/HaXml/Escape.hs @@ -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 } - diff --git a/src/Text/XML/HaXml/Html/Generate.hs b/src/Text/XML/HaXml/Html/Generate.hs --- a/src/Text/XML/HaXml/Html/Generate.hs +++ b/src/Text/XML/HaXml/Html/Generate.hs @@ -137,14 +137,14 @@ -- ( Pretty.text " -- 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.text (printableName n) Pretty.<> - Pretty.text ">" ) + , Pretty.text " + 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) diff --git a/src/Text/XML/HaXml/Html/Parse.hs b/src/Text/XML/HaXml/Html/Parse.hs --- a/src/Text/XML/HaXml/Html/Parse.hs +++ b/src/Text/XML/HaXml/Html/Parse.hs @@ -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 " @@ -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 >>= return . Comment) - , ("", processinginstruction >>= return . PI) +misc = + oneOf' [ ("", Comment <$> comment) + , ("", 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 + ( do tok TokEndClose -- self-closing debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail` - -- ( do tok TokAnyClose -- sequence (**not HTML?**) + -- ( do tok TokAnyClose -- sequence (**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 -- with no close (e.g. ) + ( do tok TokAnyClose -- with no close (e.g. ) 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 diff --git a/src/Text/XML/HaXml/Html/ParseLazy.hs b/src/Text/XML/HaXml/Html/ParseLazy.hs --- a/src/Text/XML/HaXml/Html/ParseLazy.hs +++ b/src/Text/XML/HaXml/Html/ParseLazy.hs @@ -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 " @@ -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 >>= return . Comment) - , ("", processinginstruction >>= return . PI) + oneOf' [ ("", Comment <$> comment) + , ("", 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 + ( do tok TokEndClose -- self-closing debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail` - -- ( do tok TokAnyClose -- sequence (**not HTML?**) + -- ( do tok TokAnyClose -- sequence (**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 -- with no close (e.g. ) + ( do tok TokAnyClose -- with no close (e.g. ) 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 diff --git a/src/Text/XML/HaXml/Html/Pretty.hs b/src/Text/XML/HaXml/Html/Pretty.hs --- a/src/Text/XML/HaXml/Html/Pretty.hs +++ b/src/Text/XML/HaXml/Html/Pretty.hs @@ -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 " qname n <+> diff --git a/src/Text/XML/HaXml/Lex.hs b/src/Text/XML/HaXml/Lex.hs --- a/src/Text/XML/HaXml/Lex.hs +++ b/src/Text/XML/HaXml/Lex.hs @@ -38,38 +38,38 @@ -- | The basic token type. data TokenT = - TokCommentOpen -- ^ \ - | TokPIOpen -- ^ \ - | TokSectionOpen -- ^ \ - | TokSection Section -- ^ CDATA INCLUDE IGNORE etc - | TokSpecialOpen -- ^ \ - | 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 -- ^ \ + | TokPIOpen -- ^ \ + | TokSectionOpen -- ^ \ + | TokSection Section -- ^ CDATA INCLUDE IGNORE etc + | TokSpecialOpen -- ^ \ + | 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 TokPIOpen = showString "" - showsPrec _p TokSectionOpen = showString "" - showsPrec p (TokSection s) = showsPrec p s - showsPrec _p TokSpecialOpen = 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 TokPIOpen = showString "" + showsPrec _p TokSectionOpen = showString "" + showsPrec p (TokSection s) = showsPrec p s + showsPrec _p TokSpecialOpen = 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 "": -}w)) + skip n p s (xmlAny {-InTag "": -}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 diff --git a/src/Text/XML/HaXml/Namespaces.hs b/src/Text/XML/HaXml/Namespaces.hs --- a/src/Text/XML/HaXml/Namespaces.hs +++ b/src/Text/XML/HaXml/Namespaces.hs @@ -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) -- diff --git a/src/Text/XML/HaXml/OneOfN.hs b/src/Text/XML/HaXml/OneOfN.hs --- a/src/Text/XML/HaXml/OneOfN.hs +++ b/src/Text/XML/HaXml/OneOfN.hs @@ -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 diff --git a/src/Text/XML/HaXml/Parse.hs b/src/Text/XML/HaXml/Parse.hs --- a/src/Text/XML/HaXml/Parse.hs +++ b/src/Text/XML/HaXml/Parse.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp #-} +{-# LANGUAGE CPP #-} -- | A non-validating XML parser. For the input grammar, see -- . 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 " @@ -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 >>= return . Comment) - , ("", processinginstruction >>= return . PI) + oneOf' [ ("", Comment <$> comment) + , ("", 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, , or ") @@ -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 - diff --git a/src/Text/XML/HaXml/ParseLazy.hs b/src/Text/XML/HaXml/ParseLazy.hs --- a/src/Text/XML/HaXml/ParseLazy.hs +++ b/src/Text/XML/HaXml/ParseLazy.hs @@ -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 " @@ -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 >>= return . Comment) - , ("", processinginstruction >>= return . PI) + oneOf' [ ("", Comment <$> comment) + , ("", 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, , or ") @@ -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 - diff --git a/src/Text/XML/HaXml/Pretty.hs b/src/Text/XML/HaXml/Pretty.hs --- a/src/Text/XML/HaXml/Pretty.hs +++ b/src/Text/XML/HaXml/Pretty.hs @@ -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 diff --git a/src/Text/XML/HaXml/SAX.hs b/src/Text/XML/HaXml/SAX.hs --- a/src/Text/XML/HaXml/SAX.hs +++ b/src/Text/XML/HaXml/SAX.hs @@ -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(\) - | SaxProcessingInstruction ProcessingInstruction - -- ^ A processing instruction occured (\) - | SaxComment String -- ^ A comment occured (\