HaXml 1.25.6 → 1.25.7
raw patch · 40 files changed
+656/−690 lines, 40 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Changelog.md +4/−0
- HaXml.cabal +1/−1
- src/Text/XML/HaXml/ByteStringPP.hs +5/−5
- src/Text/XML/HaXml/Combinators.hs +8/−8
- src/Text/XML/HaXml/DtdToHaskell/Convert.hs +6/−7
- src/Text/XML/HaXml/DtdToHaskell/Instance.hs +11/−12
- src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs +3/−3
- src/Text/XML/HaXml/Escape.hs +13/−26
- src/Text/XML/HaXml/Html/Generate.hs +9/−10
- src/Text/XML/HaXml/Html/Parse.hs +47/−48
- src/Text/XML/HaXml/Html/ParseLazy.hs +50/−50
- src/Text/XML/HaXml/Lex.hs +4/−4
- src/Text/XML/HaXml/Namespaces.hs +13/−12
- src/Text/XML/HaXml/OneOfN.hs +84/−84
- src/Text/XML/HaXml/Parse.hs +79/−83
- src/Text/XML/HaXml/ParseLazy.hs +79/−83
- src/Text/XML/HaXml/SAX.hs +10/−10
- src/Text/XML/HaXml/Schema/HaskellTypeModel.hs +1/−2
- src/Text/XML/HaXml/Schema/NameConversion.hs +3/−5
- src/Text/XML/HaXml/Schema/Parse.hs +23/−25
- src/Text/XML/HaXml/Schema/PrettyHaskell.hs +8/−9
- src/Text/XML/HaXml/Schema/PrettyHsBoot.hs +6/−7
- src/Text/XML/HaXml/Schema/PrimitiveTypes.hs +6/−3
- src/Text/XML/HaXml/Schema/Schema.hs +4/−5
- src/Text/XML/HaXml/Schema/TypeConversion.hs +42/−43
- src/Text/XML/HaXml/Schema/XSDTypeModel.hs +2/−3
- src/Text/XML/HaXml/ShowXmlLazy.hs +2/−3
- src/Text/XML/HaXml/TypeMapping.hs +7/−7
- src/Text/XML/HaXml/Validate.hs +10/−10
- src/Text/XML/HaXml/Verbatim.hs +3/−4
- src/Text/XML/HaXml/Wrappers.hs +4/−4
- src/Text/XML/HaXml/XmlContent.hs +2/−2
- src/Text/XML/HaXml/XmlContent/Haskell.hs +4/−4
- src/Text/XML/HaXml/XmlContent/Parser.hs +8/−8
- src/Text/XML/HaXml/Xtract/Combinators.hs +12/−12
- src/Text/XML/HaXml/Xtract/Parse.hs +16/−18
- src/tools/DtdToHaskell.hs +8/−7
- src/tools/FpMLToHaskell.hs +32/−35
- src/tools/MkOneOf.hs +14/−14
- src/tools/XsdToHaskell.hs +13/−14
Changelog.md view
@@ -1,3 +1,7 @@+## 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
HaXml.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: HaXml-version: 1.25.6+version: 1.25.7 license: LGPL license-files: COPYRIGHT, LICENCE-GPL, LICENCE-LGPL
src/Text/XML/HaXml/ByteStringPP.hs view
@@ -157,8 +157,8 @@ 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 (text ">") in ( c <> text "<" <> qname n <+> fsep (Prelude.map attribute as) $$@@ -327,11 +327,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@@ -345,5 +345,5 @@ containsDoubleQuote :: [EV] -> Bool containsDoubleQuote evs = any csq evs- where csq (EVString s) = toWord8 '"' `elem` (pack s)+ where csq (EVString s) = toWord8 '"' `elem` pack s csq _ = False
src/Text/XML/HaXml/Combinators.hs view
@@ -77,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@@ -121,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]@@ -144,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@@ -201,7 +201,7 @@ -- 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@@ -241,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@@ -304,7 +304,7 @@ -- | 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@@ -463,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 _ = ""
src/Text/XML/HaXml/DtdToHaskell/Convert.hs view
@@ -9,7 +9,7 @@ ( dtd2TypeDef ) where -import Data.List (intersperse,nub)+import Data.List (intercalate,nub) import Text.XML.HaXml.Types hiding (Name) import Text.XML.HaXml.DtdToHaskell.TypeDef@@ -25,8 +25,8 @@ ---- Apparently multiple ATTLIST decls for the same element are permitted, ---- although only one ELEMENT decl for it is allowed. dtd2TypeDef :: [MarkupDecl] -> [TypeDef]-dtd2TypeDef mds =- (concatMap convert . reverse . database []) mds+dtd2TypeDef =+ concatMap convert . reverse . database [] where database db [] = db database db (m:ms) =@@ -94,16 +94,16 @@ mkData tss fs aux n = [DataDef aux n fs (map (mkConstr n) tss)] where mkConstr m ts = (mkConsName m ts, ts)- mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts)))+ mkConsName (Name x m) sts = Name x (m++intercalate "_" (map flatten sts)) flatten (Maybe st) = {-"Maybe_" ++ -} flatten st flatten (List st) = {-"List_" ++ -} flatten st flatten (List1 st) = {-"List1_" ++ -} flatten st flatten (Tuple sts) = {-"Tuple" ++ show (length sts) ++ "_" ++ -}- concat (intersperse "_" (map flatten sts))+ intercalate "_" (map flatten sts) flatten StringMixed = "Str" flatten String = "Str" flatten (OneOf sts) = {-"OneOf" ++ show (length sts) ++ "_" ++ -}- concat (intersperse "_" (map flatten sts))+ intercalate "_" (map flatten sts) flatten Any = "Any" flatten (Defined (Name _ m)) = m @@ -132,4 +132,3 @@ mkType (EnumeratedType _) IMPLIED = Maybe (Defined (name_a e n)) mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) = Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))-
src/Text/XML/HaXml/DtdToHaskell/Instance.hs view
@@ -61,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 ">, \"++)") )@@ -88,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 "\" [] []" )@@ -115,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 "\" [] []" )@@ -244,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" @@ -265,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 @@ -280,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@@ -399,4 +399,3 @@ text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "=" $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName tag <> text "\")"<+> attrexp <+> parens (mkToElem sts vs) <+> text ") ()]")-
src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs view
@@ -69,9 +69,9 @@ . foldr1 (.) (intersperse (showChar '|') (map shows ss)) . showChar ')'- showsPrec _ (Any) = showString "ANY"- showsPrec _ (StringMixed) = showString "#PCDATA"- showsPrec _ (String) = showString "#PCDATA"+ showsPrec _ Any = showString "ANY"+ showsPrec _ StringMixed = showString "#PCDATA"+ showsPrec _ String = showString "#PCDATA" showsPrec _ (Defined (Name n _)) = showString n
src/Text/XML/HaXml/Escape.hs view
@@ -111,16 +111,13 @@ (escapeContent xmlEscaper content) escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]-escapeAttributes xmlEscaper atts =- map- (\ (name,av) -> (name,escapeAttValue xmlEscaper av))- atts+escapeAttributes xmlEscaper =+ map (\ (name,av) -> (name,escapeAttValue xmlEscaper av)) escapeAttValue :: XmlEscaper -> AttValue -> AttValue escapeAttValue xmlEscaper (AttValue attValList) = AttValue (- concat (- map+ concatMap (\ av -> case av of Right _ -> [av] Left s ->@@ -134,13 +131,11 @@ s ) attValList- ) ) escapeContent :: XmlEscaper -> [Content i] -> [Content i]-escapeContent xmlEscaper contents =- concat- (map+escapeContent xmlEscaper =+ concatMap (\ content -> case content of (CString b str i) -> map@@ -154,8 +149,6 @@ (CElem element i) -> [CElem (escapeElement xmlEscaper element) i] _ -> [content] )- contents- ) mkEscape :: XmlEscaper -> Char -> Reference mkEscape (XmlEscaper {toEscape = toescape}) ch =@@ -184,10 +177,8 @@ (unEscapeContent xmlEscaper content) unEscapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute]-unEscapeAttributes xmlEscaper atts =- map- (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av))- atts+unEscapeAttributes xmlEscaper =+ map (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av)) unEscapeAttValue :: XmlEscaper -> AttValue -> AttValue unEscapeAttValue xmlEscaper (AttValue attValList) =@@ -203,7 +194,7 @@ ) unEscapeContent :: XmlEscaper -> [Content i] -> [Content i]-unEscapeContent xmlEscaper content =+unEscapeContent xmlEscaper = map (\ cntnt -> case cntnt of CRef ref i -> case unEscapeChar xmlEscaper ref of@@ -212,7 +203,6 @@ CElem element i -> CElem (unEscapeElement xmlEscaper element) i _ -> cntnt )- content unEscapeChar :: XmlEscaper -> Reference -> Maybe Char unEscapeChar xmlEscaper ref =@@ -230,25 +220,23 @@ Elem name (compressAttributes attributes) (compressContent content) compressAttributes :: [(QName,AttValue)] -> [(QName,AttValue)]-compressAttributes atts =- map- (\ (name,av) -> (name,compressAttValue av))- atts+compressAttributes =+ map (\ (name,av) -> (name,compressAttValue av)) compressAttValue :: AttValue -> AttValue compressAttValue (AttValue l) = AttValue (compress l) where compress :: [Either String Reference] -> [Either String Reference] compress [] = []- compress (Right ref : es) = Right ref : (compress es)- compress ( (ls@(Left s1)) : es) =+ compress (Right ref : es) = Right ref : compress es+ compress ( ls@(Left s1) : es) = case compress es of (Left s2 : es2) -> Left (s1 ++ s2) : es2 es2 -> ls : es2 compressContent :: [Content i] -> [Content i] compressContent [] = []-compressContent ((csb@(CString b1 s1 i1)) : cs) =+compressContent (csb@(CString b1 s1 i1) : cs) = case compressContent cs of (CString b2 s2 _) : cs2 | b1 == b2@@ -288,4 +276,3 @@ fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes), isEscape = isescape }-
src/Text/XML/HaXml/Html/Generate.hs view
@@ -137,14 +137,14 @@ -- ( Pretty.text "</" Pretty.<> -- Pretty.text n Pretty.<> -- Pretty.text ">" )- Pretty.fcat [ ( Pretty.text "<" Pretty.<>- Pretty.text (printableName n) Pretty.<>- attrs as Pretty.<>- Pretty.text ">")+ Pretty.fcat [ Pretty.text "<" Pretty.<>+ Pretty.text (printableName n) Pretty.<>+ attrs as Pretty.<>+ Pretty.text ">" , Pretty.nest 4 (htmlprint cs)- , ( Pretty.text "</" Pretty.<>- Pretty.text (printableName n) Pretty.<>- Pretty.text ">" )+ , Pretty.text "</" Pretty.<>+ Pretty.text (printableName n) Pretty.<>+ Pretty.text ">" ] attrs = Pretty.cat . map attribute@@ -171,6 +171,5 @@ keepUntil p xs = select p ([],xs) where select _ (ls,[]) = (ls,[])- select q (ls,(y:ys)) | q y = (ls,y:ys)- | otherwise = select q (y:ls,ys)-+ select q (ls,y:ys) | q y = (ls,y:ys)+ | otherwise = select q (y:ls,ys)
src/Text/XML/HaXml/Html/Parse.hs view
@@ -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@@ -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) }@@ -236,7 +236,7 @@ xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -250,14 +250,14 @@ versioninfo :: HParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: HParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] @@ -278,11 +278,11 @@ --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,13 +293,13 @@ -- --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) (commit $ tok TokQuote)@@ -323,7 +323,7 @@ (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") [] []))@@ -343,7 +343,7 @@ 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"@@ -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,8 +570,8 @@ {- reference :: HParser Reference reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ (RefChar <$> charref) `onFail`+ (RefEntity <$> entityref) entityref :: HParser EntityRef entityref = do@@ -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,7 +665,7 @@ 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) (commit $ tok TokQuote) freetext return (EncodingDecl f)@@ -693,9 +692,9 @@ --ev :: HParser EV --ev =--- ( freetext >>= return . EVString) `onFail`+-- (EVString <$> freetext) `onFail` -- -- PEREF(EVPERef,ev) `onFail`--- ( reference >>= return . EVRef)+-- (EVRef <$> reference) attvalue :: HParser AttValue attvalue =@@ -723,4 +722,4 @@ return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData-chardata = freetext -- >>= return . CharData+chardata = freetext -- <&> CharData
src/Text/XML/HaXml/Html/ParseLazy.hs view
@@ -114,7 +114,7 @@ "form" `closes` "form" = True "label" `closes` "label" = True _ `closes` "option" = True-"thead" `closes` t | t `elem` ["colgroup"] = True+"thead" `closes` t | t == "colgroup" = True "tfoot" `closes` t | t `elem` ["thead","colgroup"] = True "tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True "colgroup" `closes` "colgroup" = True@@ -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@@ -235,7 +235,7 @@ xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -249,14 +249,14 @@ versioninfo :: HParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: HParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] @@ -277,11 +277,11 @@ --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,13 +292,13 @@ -- --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) (commit $ tok TokQuote)@@ -322,7 +322,7 @@ (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") [] []))@@ -342,9 +342,9 @@ 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,8 +508,8 @@ -- --enumeratedtype :: HParser EnumeratedType --enumeratedtype =--- ( notationtype >>= return . NotationType) `onFail`--- ( enumeration >>= return . Enumeration)+-- (NotationType <$> notationtype) `onFail`+-- (Enumeration <$> enumeration) -- --notationtype :: HParser NotationType --notationtype = do@@ -556,7 +556,7 @@ -- return (IgnoreSectContents i is) -- --ignore :: HParser Ignore---ignore = freetext >>= return . Ignore+--ignore = Ignore <$> freetext reference :: HParser Reference reference = do@@ -571,8 +571,8 @@ {- reference :: HParser Reference reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ (RefChar <$> charref) `onFail`+ (RefEntity <$> entityref) entityref :: HParser EntityRef entityref = do@@ -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,7 +667,7 @@ 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) (commit $ tok TokQuote) freetext return (EncodingDecl f)@@ -694,9 +694,9 @@ --ev :: HParser EV --ev =--- ( freetext >>= return . EVString) `onFail`+-- (EVString <$> freetext) `onFail` -- -- PEREF(EVPERef,ev) `onFail`--- ( reference >>= return . EVRef)+-- (EVRef <$> reference) attvalue :: HParser AttValue attvalue =@@ -724,4 +724,4 @@ return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData-chardata = freetext -- >>= return . CharData+chardata = freetext -- <&> CharData
src/Text/XML/HaXml/Lex.hs view
@@ -282,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 @@ -301,7 +301,7 @@ let p0 = addcol n p in textUntil "]]>" TokSectionClose "" p0 p0 (drop n s) (blank xmlAny w) k w p s n =- skip n p s (xmlAny ({-InTag "<![section[ ... ]]>": -}w))+ skip n p s (xmlAny {-InTag "<![section[ ... ]]>": -}w) xmlSpecial w p s | "DOCTYPE" `prefixes` s = emit (TokSpecial DOCTYPEx) p: k 7@@ -316,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 =@@ -332,7 +332,7 @@ xmlContent acc _w _pos p [] = if all isSpace acc then [] else lexerror "unexpected EOF between tags" p xmlContent acc w pos p (s:ss)- | elem s "<&" = {- if all isSpace acc then xmlAny w p (s:ss) else -}+ | s `elem` "<&" = {- if all isSpace acc then xmlAny w p (s:ss) else -} emit (TokFreeText (reverse acc)) pos: xmlAny w p (s:ss) | isSpace s = xmlContent (s:acc) w pos (white s p) ss | otherwise = xmlContent (s:acc) w pos (addcol 1 p) ss
src/Text/XML/HaXml/Namespaces.hs view
@@ -16,6 +16,7 @@ import Prelude hiding (lookup) import Text.XML.HaXml.Types import Data.Map as Map (Map, insert, lookup, empty)+import Data.Maybe (fromMaybe) import Data.List (isPrefixOf) -- | The null Namespace (no prefix, no URI).@@ -57,13 +58,13 @@ qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName qualify def env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in- QN (maybe nullNamespace{nsPrefix=pre} id+ QN (fromMaybe nullNamespace {nsPrefix=pre} (Map.lookup pre env)) nm | Just d <- def = QN d n | otherwise = N n qualify _ env qn@(QN ns n)- | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n+ | null (nsURI ns) = QN (fromMaybe ns (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | 'deQualify' has the same signature as 'qualify', but ignores the@@ -83,13 +84,13 @@ qualifyExceptLocal (Just def) env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in if nsPrefix def == pre then N nm- else QN (maybe nullNamespace{nsPrefix=pre} id+ else QN (fromMaybe nullNamespace{nsPrefix=pre} (Map.lookup pre env)) nm | otherwise = N n qualifyExceptLocal (Just def) env qn@(QN ns n) | def==ns = N n- | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n+ | null (nsURI ns) = QN (fromMaybe ns (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | The initial Namespace environment. It always has bindings for the@@ -100,7 +101,7 @@ ,nsURI="http://www.w3.org/2000/xmlns/"} $ Map.insert "xml" Namespace{nsPrefix="xml" ,nsURI="http://www.w3.org/XML/1998/namespace"}- $ Map.empty+ Map.empty -- | Add a fresh Namespace into the Namespace environment. It is not -- permitted to rebind the prefixes 'xml' or 'xmlns', but that is not@@ -130,7 +131,7 @@ where qualifyInDTD = qualify Nothing initNamespaceEnv walkProlog (Prolog xml misc0 mDTD misc1) =- Prolog xml misc0 (maybe Nothing (Just . walkDTD) mDTD) misc1+ Prolog xml misc0 (fmap walkDTD mDTD) misc1 walkDTD (DTD qn ext mds) = DTD (qualifyInDTD qn) ext (map walkMD mds) -- walkMD (Element ed) = Element (walkED ed)@@ -158,17 +159,17 @@ 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} matching :: (String->Bool) -> [Attribute] -> [Attribute] matching p = filter (p . printableName . fst)
src/Text/XML/HaXml/OneOfN.hs view
@@ -18,11 +18,11 @@ => XmlContent (OneOf1 a) where parseContents =- (choice OneOf1- $ fail "OneOf1")+ choice OneOf1+ $ fail "OneOf1" toContents (OneOf1 x) = toContents x -foldOneOf1 :: (a->z) -> +foldOneOf1 :: (a->z) -> OneOf1 a -> z foldOneOf1 a (OneOf1 z) = a z@@ -46,12 +46,12 @@ => XmlContent (OneOf2 a b) where parseContents =- (choice OneOf2 $ choice TwoOf2- $ fail "OneOf2")+ choice OneOf2 $ choice TwoOf2+ $ fail "OneOf2" toContents (OneOf2 x) = toContents x toContents (TwoOf2 x) = toContents x -foldOneOf2 :: (a->z) -> (b->z) -> +foldOneOf2 :: (a->z) -> (b->z) -> OneOf2 a b -> z foldOneOf2 a b (OneOf2 z) = a z@@ -70,13 +70,13 @@ => XmlContent (OneOf3 a b c) where parseContents =- (choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3- $ fail "OneOf3")+ choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3+ $ fail "OneOf3" toContents (OneOf3 x) = toContents x toContents (TwoOf3 x) = toContents x toContents (ThreeOf3 x) = toContents x -foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> +foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> OneOf3 a b c -> z foldOneOf3 a b c (OneOf3 z) = a z@@ -96,14 +96,14 @@ => XmlContent (OneOf4 a b c d) where parseContents =- (choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4- $ fail "OneOf4")+ choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4+ $ fail "OneOf4" toContents (OneOf4 x) = toContents x toContents (TwoOf4 x) = toContents x toContents (ThreeOf4 x) = toContents x toContents (FourOf4 x) = toContents x -foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> +foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> OneOf4 a b c d -> z foldOneOf4 a b c d (OneOf4 z) = a z@@ -124,16 +124,16 @@ => XmlContent (OneOf5 a b c d e) where parseContents =- (choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5+ choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5 $ choice FiveOf5- $ fail "OneOf5")+ $ fail "OneOf5" toContents (OneOf5 x) = toContents x toContents (TwoOf5 x) = toContents x toContents (ThreeOf5 x) = toContents x toContents (FourOf5 x) = toContents x toContents (FiveOf5 x) = toContents x -foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> +foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> OneOf5 a b c d e -> z foldOneOf5 a b c d e (OneOf5 z) = a z@@ -157,9 +157,9 @@ => XmlContent (OneOf6 a b c d e f) where parseContents =- (choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6+ choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6 $ choice FiveOf6 $ choice SixOf6- $ fail "OneOf6")+ $ fail "OneOf6" toContents (OneOf6 x) = toContents x toContents (TwoOf6 x) = toContents x toContents (ThreeOf6 x) = toContents x@@ -167,7 +167,7 @@ toContents (FiveOf6 x) = toContents x toContents (SixOf6 x) = toContents x -foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> +foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> OneOf6 a b c d e f -> z foldOneOf6 a b c d e f (OneOf6 z) = a z@@ -193,9 +193,9 @@ => XmlContent (OneOf7 a b c d e f g) where parseContents =- (choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7+ choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7 $ choice FiveOf7 $ choice SixOf7 $ choice SevenOf7- $ fail "OneOf7")+ $ fail "OneOf7" toContents (OneOf7 x) = toContents x toContents (TwoOf7 x) = toContents x toContents (ThreeOf7 x) = toContents x@@ -204,8 +204,8 @@ toContents (SixOf7 x) = toContents x toContents (SevenOf7 x) = toContents x -foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> +foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> OneOf7 a b c d e f g -> z foldOneOf7 a b c d e f g (OneOf7 z) = a z@@ -232,9 +232,9 @@ => XmlContent (OneOf8 a b c d e f g h) where parseContents =- (choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8+ choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8 $ choice FiveOf8 $ choice SixOf8 $ choice SevenOf8 $ choice EightOf8- $ fail "OneOf8")+ $ fail "OneOf8" toContents (OneOf8 x) = toContents x toContents (TwoOf8 x) = toContents x toContents (ThreeOf8 x) = toContents x@@ -244,8 +244,8 @@ toContents (SevenOf8 x) = toContents x toContents (EightOf8 x) = toContents x -foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> +foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> OneOf8 a b c d e f g h -> z foldOneOf8 a b c d e f g h (OneOf8 z) = a z@@ -273,10 +273,10 @@ => XmlContent (OneOf9 a b c d e f g h i) where parseContents =- (choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9+ choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9 $ choice FiveOf9 $ choice SixOf9 $ choice SevenOf9 $ choice EightOf9 $ choice NineOf9- $ fail "OneOf9")+ $ fail "OneOf9" toContents (OneOf9 x) = toContents x toContents (TwoOf9 x) = toContents x toContents (ThreeOf9 x) = toContents x@@ -287,8 +287,8 @@ toContents (EightOf9 x) = toContents x toContents (NineOf9 x) = toContents x -foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> +foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> OneOf9 a b c d e f g h i -> z foldOneOf9 a b c d e f g h i (OneOf9 z) = a z@@ -317,10 +317,10 @@ => XmlContent (OneOf10 a b c d e f g h i j) where parseContents =- (choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10+ choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10 $ choice FiveOf10 $ choice SixOf10 $ choice SevenOf10 $ choice EightOf10 $ choice NineOf10 $ choice TenOf10- $ fail "OneOf10")+ $ fail "OneOf10" toContents (OneOf10 x) = toContents x toContents (TwoOf10 x) = toContents x toContents (ThreeOf10 x) = toContents x@@ -332,8 +332,8 @@ toContents (NineOf10 x) = toContents x toContents (TenOf10 x) = toContents x -foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> +foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> OneOf10 a b c d e f g h i j -> z foldOneOf10 a b c d e f g h i j (OneOf10 z) = a z@@ -366,11 +366,11 @@ => XmlContent (OneOf11 a b c d e f g h i j k) where parseContents =- (choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11+ choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11 $ choice FiveOf11 $ choice SixOf11 $ choice SevenOf11 $ choice EightOf11 $ choice NineOf11 $ choice TenOf11 $ choice ElevenOf11- $ fail "OneOf11")+ $ fail "OneOf11" toContents (OneOf11 x) = toContents x toContents (TwoOf11 x) = toContents x toContents (ThreeOf11 x) = toContents x@@ -383,8 +383,8 @@ toContents (TenOf11 x) = toContents x toContents (ElevenOf11 x) = toContents x -foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> +foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> OneOf11 a b c d e f g h i j k -> z foldOneOf11 a b c d e f g h i j k (OneOf11 z) = a z@@ -418,11 +418,11 @@ => XmlContent (OneOf12 a b c d e f g h i j k l) where parseContents =- (choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12+ choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12 $ choice FiveOf12 $ choice SixOf12 $ choice SevenOf12 $ choice EightOf12 $ choice NineOf12 $ choice TenOf12 $ choice ElevenOf12 $ choice TwelveOf12- $ fail "OneOf12")+ $ fail "OneOf12" toContents (OneOf12 x) = toContents x toContents (TwoOf12 x) = toContents x toContents (ThreeOf12 x) = toContents x@@ -436,8 +436,8 @@ toContents (ElevenOf12 x) = toContents x toContents (TwelveOf12 x) = toContents x -foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> +foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> OneOf12 a b c d e f g h i j k l -> z foldOneOf12 a b c d e f g h i j k l (OneOf12 z) = a z@@ -472,11 +472,11 @@ => XmlContent (OneOf13 a b c d e f g h i j k l m) where parseContents =- (choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13+ choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13 $ choice FiveOf13 $ choice SixOf13 $ choice SevenOf13 $ choice EightOf13 $ choice NineOf13 $ choice TenOf13 $ choice ElevenOf13 $ choice TwelveOf13 $ choice ThirteenOf13- $ fail "OneOf13")+ $ fail "OneOf13" toContents (OneOf13 x) = toContents x toContents (TwoOf13 x) = toContents x toContents (ThreeOf13 x) = toContents x@@ -491,9 +491,9 @@ toContents (TwelveOf13 x) = toContents x toContents (ThirteenOf13 x) = toContents x -foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> +foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> OneOf13 a b c d e f g h i j k l m -> z foldOneOf13 a b c d e f g h i j k l m (OneOf13 z) = a z@@ -529,12 +529,12 @@ => XmlContent (OneOf14 a b c d e f g h i j k l m n) where parseContents =- (choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14+ choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14 $ choice FiveOf14 $ choice SixOf14 $ choice SevenOf14 $ choice EightOf14 $ choice NineOf14 $ choice TenOf14 $ choice ElevenOf14 $ choice TwelveOf14 $ choice ThirteenOf14 $ choice FourteenOf14- $ fail "OneOf14")+ $ fail "OneOf14" toContents (OneOf14 x) = toContents x toContents (TwoOf14 x) = toContents x toContents (ThreeOf14 x) = toContents x@@ -550,9 +550,9 @@ toContents (ThirteenOf14 x) = toContents x toContents (FourteenOf14 x) = toContents x -foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> +foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> OneOf14 a b c d e f g h i j k l m n -> z foldOneOf14 a b c d e f g h i j k l m n (OneOf14 z) = a z@@ -590,12 +590,12 @@ => XmlContent (OneOf15 a b c d e f g h i j k l m n o) where parseContents =- (choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15+ choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15 $ choice FiveOf15 $ choice SixOf15 $ choice SevenOf15 $ choice EightOf15 $ choice NineOf15 $ choice TenOf15 $ choice ElevenOf15 $ choice TwelveOf15 $ choice ThirteenOf15 $ choice FourteenOf15 $ choice FifteenOf15- $ fail "OneOf15")+ $ fail "OneOf15" toContents (OneOf15 x) = toContents x toContents (TwoOf15 x) = toContents x toContents (ThreeOf15 x) = toContents x@@ -612,9 +612,9 @@ toContents (FourteenOf15 x) = toContents x toContents (FifteenOf15 x) = toContents x -foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> +foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> OneOf15 a b c d e f g h i j k l m n o -> z foldOneOf15 a b c d e f g h i j k l m n o (OneOf15 z) = a z@@ -655,12 +655,12 @@ => XmlContent (OneOf16 a b c d e f g h i j k l m n o p) where parseContents =- (choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16+ choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16 $ choice FiveOf16 $ choice SixOf16 $ choice SevenOf16 $ choice EightOf16 $ choice NineOf16 $ choice TenOf16 $ choice ElevenOf16 $ choice TwelveOf16 $ choice ThirteenOf16 $ choice FourteenOf16 $ choice FifteenOf16 $ choice SixteenOf16- $ fail "OneOf16")+ $ fail "OneOf16" toContents (OneOf16 x) = toContents x toContents (TwoOf16 x) = toContents x toContents (ThreeOf16 x) = toContents x@@ -678,9 +678,9 @@ toContents (FifteenOf16 x) = toContents x toContents (SixteenOf16 x) = toContents x -foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> +foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> OneOf16 a b c d e f g h i j k l m n o p -> z foldOneOf16 a b c d e f g h i j k l m n o p (OneOf16 z) = a z@@ -722,13 +722,13 @@ => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q) where parseContents =- (choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17+ choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17 $ choice FiveOf17 $ choice SixOf17 $ choice SevenOf17 $ choice EightOf17 $ choice NineOf17 $ choice TenOf17 $ choice ElevenOf17 $ choice TwelveOf17 $ choice ThirteenOf17 $ choice FourteenOf17 $ choice FifteenOf17 $ choice SixteenOf17 $ choice SeventeenOf17- $ fail "OneOf17")+ $ fail "OneOf17" toContents (OneOf17 x) = toContents x toContents (TwoOf17 x) = toContents x toContents (ThreeOf17 x) = toContents x@@ -747,9 +747,9 @@ toContents (SixteenOf17 x) = toContents x toContents (SeventeenOf17 x) = toContents x -foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> +foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> OneOf17 a b c d e f g h i j k l m n o p q -> z foldOneOf17 a b c d e f g h i j k l m n o p q (OneOf17 z) = a z@@ -792,13 +792,13 @@ => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r) where parseContents =- (choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18+ choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18 $ choice FiveOf18 $ choice SixOf18 $ choice SevenOf18 $ choice EightOf18 $ choice NineOf18 $ choice TenOf18 $ choice ElevenOf18 $ choice TwelveOf18 $ choice ThirteenOf18 $ choice FourteenOf18 $ choice FifteenOf18 $ choice SixteenOf18 $ choice SeventeenOf18 $ choice EighteenOf18- $ fail "OneOf18")+ $ fail "OneOf18" toContents (OneOf18 x) = toContents x toContents (TwoOf18 x) = toContents x toContents (ThreeOf18 x) = toContents x@@ -818,9 +818,9 @@ toContents (SeventeenOf18 x) = toContents x toContents (EighteenOf18 x) = toContents x -foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> +foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> OneOf18 a b c d e f g h i j k l m n o p q r -> z foldOneOf18 a b c d e f g h i j k l m n o p q r (OneOf18 z) = a z@@ -865,13 +865,13 @@ => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s) where parseContents =- (choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19+ choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19 $ choice FiveOf19 $ choice SixOf19 $ choice SevenOf19 $ choice EightOf19 $ choice NineOf19 $ choice TenOf19 $ choice ElevenOf19 $ choice TwelveOf19 $ choice ThirteenOf19 $ choice FourteenOf19 $ choice FifteenOf19 $ choice SixteenOf19 $ choice SeventeenOf19 $ choice EighteenOf19 $ choice NineteenOf19- $ fail "OneOf19")+ $ fail "OneOf19" toContents (OneOf19 x) = toContents x toContents (TwoOf19 x) = toContents x toContents (ThreeOf19 x) = toContents x@@ -892,10 +892,10 @@ toContents (EighteenOf19 x) = toContents x toContents (NineteenOf19 x) = toContents x -foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> - (s->z) -> +foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) ->+ (s->z) -> OneOf19 a b c d e f g h i j k l m n o p q r s -> z foldOneOf19 a b c d e f g h i j k l m n o p q r s (OneOf19 z) = a z@@ -941,14 +941,14 @@ => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t) where parseContents =- (choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20+ choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20 $ choice FiveOf20 $ choice SixOf20 $ choice SevenOf20 $ choice EightOf20 $ choice NineOf20 $ choice TenOf20 $ choice ElevenOf20 $ choice TwelveOf20 $ choice ThirteenOf20 $ choice FourteenOf20 $ choice FifteenOf20 $ choice SixteenOf20 $ choice SeventeenOf20 $ choice EighteenOf20 $ choice NineteenOf20 $ choice TwentyOf20- $ fail "OneOf20")+ $ fail "OneOf20" toContents (OneOf20 x) = toContents x toContents (TwoOf20 x) = toContents x toContents (ThreeOf20 x) = toContents x@@ -970,10 +970,10 @@ toContents (NineteenOf20 x) = toContents x toContents (TwentyOf20 x) = toContents x -foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> - (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> - (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> - (s->z) -> (t->z) -> +foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) ->+ (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) ->+ (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) ->+ (s->z) -> (t->z) -> OneOf20 a b c d e f g h i j k l m n o p q r s t -> z foldOneOf20 a b c d e f g h i j k l m n o p q r s
src/Text/XML/HaXml/Parse.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-} -- | A non-validating XML parser. For the input grammar, see -- <http://www.w3.org/TR/REC-xml>. module Text.XML.HaXml.Parse@@ -32,7 +32,7 @@ import Prelude hiding (either,maybe,sequence) import qualified Prelude (either) import Data.Maybe hiding (maybe)-import Data.List (intersperse) -- debugging only+import Data.List (intercalate) import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex)@@ -192,13 +192,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@@ -216,7 +216,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) }@@ -333,7 +333,7 @@ xmldecl :: XParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -349,14 +349,14 @@ versioninfo :: XParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: XParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] -- | Return a DOCTYPE decl, indicating a DTD.@@ -370,16 +370,16 @@ 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"++)@@ -393,12 +393,12 @@ 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) (commit $ tok TokQuote)@@ -488,11 +488,11 @@ ; return (c' p) } where- content' = oneOf' [ ("element", element >>= return . CElem)- , ("chardata", chardata >>= return . CString False)- , ("reference", reference >>= return . CRef)- , ("CDATA", cdsect >>= return . CString True)- , ("misc", misc >>= return . CMisc)+ content' = oneOf' [ ("element", CElem <$> element )+ , ("chardata", CString False <$> chardata )+ , ("reference", CRef <$> reference)+ , ("CDATA", CString True <$> cdsect )+ , ("misc", CMisc <$> misc ) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")@@ -515,8 +515,8 @@ 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)")@@ -534,33 +534,33 @@ (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 "++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))+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 debugShowCP :: CP -> String debugShowCP cp = case cp of TagName n m -> printableName n++debugShowModifier m- Choice cps m -> '(': concat (intersperse "|" (map debugShowCP cps))++")"++debugShowModifier m- Seq cps m -> '(': concat (intersperse "," (map debugShowCP cps))++")"++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 -> ""@@ -575,12 +575,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") @@ -605,21 +605,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"@@ -629,8 +629,8 @@ 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"++) @@ -719,8 +719,8 @@ {- -- following is incorrect reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ ( RefChar <$> charref) `onFail`+ ( RefEntity <$> entityref) entityref :: XParser EntityRef entityref = do@@ -741,8 +741,8 @@ entitydecl :: XParser EntityDecl entitydecl =- ( gedecl >>= return . EntityGEDecl) `onFail`- ( pedecl >>= return . EntityPEDecl)+ ( EntityGEDecl <$> gedecl) `onFail`+ ( EntityPEDecl <$> pedecl) gedecl :: XParser GEDecl gedecl = do@@ -767,7 +767,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))@@ -775,32 +775,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"@@ -820,7 +817,7 @@ 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) (commit $ tok TokQuote) freetext return (EncodingDecl f)@@ -837,8 +834,7 @@ publicid :: XParser PublicID publicid = do word "PUBLIC"- p <- pubidliteral- return (PUBLICID p)+ PUBLICID <$> pubidliteral entityvalue :: XParser EntityValue entityvalue = do@@ -850,18 +846,18 @@ -- 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"++)
src/Text/XML/HaXml/ParseLazy.hs view
@@ -31,7 +31,7 @@ import Prelude hiding (either,maybe,sequence,catch) import qualified Prelude (either) import Data.Maybe hiding (maybe)-import Data.List (intersperse) -- debugging only+import Data.List (intercalate) import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex)@@ -196,13 +196,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@@ -220,7 +220,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) }@@ -302,7 +302,7 @@ -- 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 @@ -342,7 +342,7 @@ xmldecl :: XParser XMLDecl xmldecl = do tok TokPIOpen- (word "xml" `onFail` word "XML")+ word "xml" `onFail` word "XML" p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"@@ -359,14 +359,14 @@ versioninfo :: XParser VersionInfo versioninfo = do- (word "version" `onFail` word "VERSION")+ word "version" `onFail` word "VERSION" tok TokEqual bracket (tok TokQuote) (commit $ tok TokQuote) freetext misc :: XParser Misc misc =- oneOf' [ ("<!--comment-->", comment >>= return . Comment)- , ("<?PI?>", processinginstruction >>= return . PI)+ oneOf' [ ("<!--comment-->", Comment <$> comment)+ , ("<?PI?>", PI <$> processinginstruction) ] -- | Return a DOCTYPE decl, indicating a DTD.@@ -380,16 +380,16 @@ 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"++)@@ -403,12 +403,12 @@ 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) (commit $ tok TokQuote)@@ -497,11 +497,11 @@ ; return (c' p) } where- content' = oneOf' [ ("element", element >>= return . CElem)- , ("chardata", chardata >>= return . CString False)- , ("reference", reference >>= return . CRef)- , ("CDATA", cdsect >>= return . CString True)- , ("misc", misc >>= return . CMisc)+ content' = oneOf' [ ("element", CElem <$> element)+ , ("chardata", CString False <$> chardata)+ , ("reference", CRef <$> reference)+ , ("CDATA", CString True <$> cdsect)+ , ("misc", CMisc <$> misc) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")@@ -524,8 +524,8 @@ 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)")@@ -543,33 +543,33 @@ (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 "++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))+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 debugShowCP :: CP -> String debugShowCP cp = case cp of TagName n m -> printableName n++debugShowModifier m- Choice cps m -> '(': concat (intersperse "|" (map debugShowCP cps))++")"++debugShowModifier m- Seq cps m -> '(': concat (intersperse "," (map debugShowCP cps))++")"++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 -> ""@@ -584,12 +584,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") @@ -614,21 +614,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"@@ -638,8 +638,8 @@ 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"++) @@ -728,8 +728,8 @@ {- -- following is incorrect reference =- ( charref >>= return . RefChar) `onFail`- ( entityref >>= return . RefEntity)+ ( RefChar <$> charref) `onFail`+ ( RefEntity <$> entityref) entityref :: XParser EntityRef entityref = do@@ -750,8 +750,8 @@ entitydecl :: XParser EntityDecl entitydecl =- ( gedecl >>= return . EntityGEDecl) `onFail`- ( pedecl >>= return . EntityPEDecl)+ ( EntityGEDecl <$> gedecl) `onFail`+ ( EntityPEDecl <$> pedecl) gedecl :: XParser GEDecl gedecl = do@@ -776,7 +776,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))@@ -784,32 +784,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"@@ -829,7 +826,7 @@ 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) (commit $ tok TokQuote) freetext return (EncodingDecl f)@@ -846,8 +843,7 @@ publicid :: XParser PublicID publicid = do word "PUBLIC"- p <- pubidliteral- return (PUBLICID p)+ PUBLICID <$> pubidliteral entityvalue :: XParser EntityValue entityvalue = do@@ -860,18 +856,18 @@ 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"++)
src/Text/XML/HaXml/SAX.hs view
@@ -61,11 +61,11 @@ saxelementopen = do tok TokAnyOpen (ElemTag (N n) as) <- elemtag -- no QN ever generated during parsing- (( do tok TokEndClose- return (SaxElementTag n as)) `onFail`- ( do tok TokAnyClose- return (SaxElementOpen n as))- `onFail` fail "missing > or /> in element tag")+ ( do tok TokEndClose+ return (SaxElementTag n as)) `onFail`+ ( do tok TokAnyClose+ return (SaxElementOpen n as))+ `onFail` fail "missing > or /> in element tag" saxelementclose :: XParser SaxElement saxelementclose = do@@ -75,19 +75,19 @@ return (SaxElementClose n) saxcomment :: XParser SaxElement-saxcomment = comment >>= return . SaxComment+saxcomment = SaxComment <$> comment saxchardata :: XParser SaxElement saxchardata =- (cdsect >>= return . SaxCharData)+ (SaxCharData <$>cdsect) `onFail`- (chardata >>= return . SaxCharData)+ (SaxCharData <$>chardata) saxreference :: XParser SaxElement-saxreference = reference >>= return . SaxReference+saxreference = SaxReference <$> reference saxdoctypedecl :: XParser SaxElement-saxdoctypedecl = doctypedecl >>= return . SaxDocTypeDecl+saxdoctypedecl = SaxDocTypeDecl <$> doctypedecl saxprocessinginstruction :: XParser SaxElement saxprocessinginstruction = fmap SaxProcessingInstruction processinginstruction
src/Text/XML/HaXml/Schema/HaskellTypeModel.hs view
@@ -189,7 +189,6 @@ xsdinclude _ = False xsdimport (XSDImport _ _ _) = True xsdimport _ = False- xsdQualification nss = fmap (XName . N . nsPrefix) $+ xsdQualification nss = XName . N . nsPrefix <$> lookupBy ((==xsd).nsURI) nss where xsd = "http://www.w3.org/2001/XMLSchema"-
src/Text/XML/HaXml/Schema/NameConversion.hs view
@@ -105,8 +105,7 @@ -- e.g. fpml-dividend-swaps-4-7.xsd becomes FpML.V47.Swaps.Dividend -- but fpml-posttrade-execution-4-7.xsd becomes FpML.V47.PostTrade.Execution fpml :: String -> String-fpml = concat- . intersperse "." -- put the dots in+fpml = intercalate "." -- put the dots in . ("Data":) -- root of the Haskell module namespace . rearrange -- hierarchy shuffling, dependent on names . map cap -- make into nice module names@@ -177,7 +176,7 @@ local = Prelude.last . hierarchy - mkVarId ("id") = "ID"+ mkVarId "id" = "ID" mkVarId (v:vs) = toLower v: map escape vs mkConId (v:vs) = toUpper v: map escape vs @@ -185,7 +184,7 @@ | length t < 35 = concatMap shortenWord (splitWords t) | otherwise = map toLower (head t: filter isUpper (tail t)) splitWords "" = []- splitWords (u:s) = let (w,rest) = span (not . (\c->isUpper c || c=='_')) s+ splitWords (u:s) = let (w,rest) = break (\c->isUpper c || c=='_') s in (u:w) : splitWords rest shortenWord "Request" = "Req" -- some special cases@@ -220,4 +219,3 @@ | otherwise -> pref++[c] isVowel = (`elem` "aeiouy")-
src/Text/XML/HaXml/Schema/Parse.hs view
@@ -23,15 +23,14 @@ -- | Qualify an ordinary name with the XSD namespace. xsd :: Name -> QName-xsd name = QN Namespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"}- name+xsd = QN Namespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"} -- | Predicate for comparing against an XSD-qualified name. (Also accepts -- unqualified names, but this is probably a bit too lax. Doing it right -- would require checking to see whether the current schema module's default -- namespace is XSD or not.) xsdTag :: String -> Content Posn -> Bool-xsdTag tag (CElem (Elem qn _ _) _) = qn == xsd tag || qn == (N tag)+xsdTag tag (CElem (Elem qn _ _) _) = qn == xsd tag || qn == N tag xsdTag _ _ = False -- | We need a Parser monad for reading from a sequence of generic XML@@ -124,7 +123,7 @@ ++printableName qn++"=\"" ++show atv++"\": "++msg Success [] v -> Success [] v- Success xs _ -> Committed $ + Success xs _ -> Committed $ Failure xs $ "Attribute parsing excess text: " ++printableName qn++"=\""@@ -157,7 +156,7 @@ -- me the prefix corresponding to the targetNamespace. targetPrefix :: Maybe TargetNamespace -> [Namespace] -> Maybe String targetPrefix Nothing _ = Nothing-targetPrefix (Just uri) nss = fmap nsPrefix $ lookupBy ((==uri).nsURI) nss+targetPrefix (Just uri) nss = nsPrefix <$> lookupBy ((==uri).nsURI) nss -- | An auxiliary you might expect to find in Data.List lookupBy :: (a->Bool) -> [a] -> Maybe a@@ -207,14 +206,13 @@ definiteAnnotation :: XsdParser Annotation definiteAnnotation = do e <- xsdElement "annotation"- ( fmap Documentation $ interiorWith (xsdTag "documentation")- (allChildren text) e- ) `onFail` (- fmap AppInfo $ interiorWith (xsdTag "documentation")- (allChildren text) e- ) `onFail` (+ ( Documentation <$> interiorWith (xsdTag "documentation")+ (allChildren text) e)+ `onFail`+ (AppInfo <$> interiorWith (xsdTag "documentation")+ (allChildren text) e)+ `onFail` return (NoAnnotation "failed to parse")- ) -- | Parse a FormDefault attribute. qform :: TextParser QForm@@ -243,7 +241,7 @@ schemaItem qual = oneOf' [ ("xsd:include", include) , ("xsd:import", import_)- , ("xsd:redefine", (redefine qual))+ , ("xsd:redefine", redefine qual) , ("xsd:annotation", fmap Annotation definiteAnnotation) -- , ("xsd:simpleType", fmap Simple (simpleType qual))@@ -256,7 +254,7 @@ -- sigh , ("xs:include", include) , ("xs:import", import_)- , ("xs:redefine", (redefine qual))+ , ("xs:redefine", redefine qual) , ("xs:annotation", fmap Annotation definiteAnnotation) -- , ("xs:simpleType", fmap Simple (simpleType qual))@@ -333,7 +331,7 @@ restriction1 a b = return (RestrictSim1 a b) `apply` (return Restriction1 `apply` particle q) restrictType a b = return (RestrictType a b)- `apply` (optional (simpleType q))+ `apply` optional (simpleType q) `apply` many1 aFacet aFacet :: XsdParser Facet@@ -385,7 +383,7 @@ `apply` (attribute (N "mixed") bool e `onFail` return False) `apply` interiorWith (not.xsdTag "annotation") stuff e ) `onFail` (- do fmap ThisType $ particleAttrs q+ do ThisType <$> particleAttrs q ) where stuff :: XsdParser (Either Restriction1 Extension)@@ -532,9 +530,9 @@ `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` (attribute (N "use") use e `onFail` return Optional)- `apply` (optional (attribute (N "default") (fmap Left string) e+ `apply` optional (attribute (N "default") (fmap Left string) e `onFail`- attribute (N "fixed") (fmap Right string) e))+ attribute (N "fixed") (fmap Right string) e) `apply` (attribute (xsd "form") qform e `onFail` return Unqualified) `apply` interiorWith (xsdTag "simpleType") (optional (simpleType q)) e@@ -543,8 +541,8 @@ -- | Parse an occurrence range from attributes of given element. occurs :: Element Posn -> XsdParser Occurs occurs e = return Occurs- `apply` (optional $ attribute (N "minOccurs") parseDec e)- `apply` (optional $ attribute (N "maxOccurs") maxDec e)+ `apply` optional (attribute (N "minOccurs") parseDec e)+ `apply` optional (attribute (N "maxOccurs") maxDec e) where maxDec = parseDec `onFail`@@ -611,7 +609,7 @@ -- | Text parser for an arbitrary string consisting of possibly multiple tokens. string :: TextParser String-string = fmap concat $ many (space `onFail` word)+string = concat <$> many (space `onFail` word) space :: TextParser String space = many1 $ satisfy isSpace@@ -648,12 +646,12 @@ -- | Parse an attribute value that should be a QName. qname :: (String->String->QName) -> TextParser QName qname q = do a <- word- ( do ":" <- word- b <- many (satisfy (/=':'))- return (q a b)+ (do ":" <- word+ b <- many (satisfy (/=':'))+ return (q a b) `onFail` do cs <- many next- return (N (a++cs)) )+ return (N (a++cs))) -- | Parse an attribute value that should be a simple Name. name :: TextParser Name
src/Text/XML/HaXml/Schema/PrettyHaskell.hs view
@@ -67,11 +67,10 @@ ++paragraph 52 s) seq) [1..]- $ map (map safeComment)- $ nested+ $ map (map safeComment) nested safeComment Text = "mixed text" safeComment e@Element{} = fromMaybe (xname $ elem_name e) (elem_comment e)- safeComment e@_ = fromMaybe ("unknown") (elem_comment e)+ safeComment e = fromMaybe "unknown" (elem_comment e) xname (XName (N x)) = x xname (XName (QN ns x)) = nsPrefix ns++":"++x @@ -96,7 +95,7 @@ ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q)-ppFieldId nx = \t-> ppHName . fieldid nx t+ppFieldId nx t = ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc@@ -484,7 +483,7 @@ -- = (text "-- element" <> ppUnqConId nx n) <+> text "::" -- <+> text "XMLParser" <+> ppConId nx t -- $$ text "-- declared in Instances module"- | otherwise = ppComment Before comm+{- | otherwise-} = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "element" <> ppUnqConId nx n) <+> text "="@@ -721,14 +720,14 @@ <+> text "will be declared later in module" <+> ppModId nx mod $$ ppSuperExtension nx super grandSupers (t,Nothing) ppSuperExtension nx super grandSupers (t,Nothing) =- vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers))+ vcat (map (ppSuper t . reverse) (drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx gs <+> text "where" $$ nest 4 (text "supertype" <+>- (ppvList "=" "." "" coerce (zip (tail gss++[t]) gss)))+ ppvList "=" "." "" coerce (zip (tail gss++[t]) gss)) coerce (a,b) = text "(supertype ::" <+> ppUnqConId nx a <+> text "->" <+> ppConId nx b <> text ")"@@ -878,6 +877,6 @@ | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $- dropWhile pred [(n++show i) | i <- [2..]]+ dropWhile pred [n++show i | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $- dropWhile pred [(n++show i) | i <- [2..]]+ dropWhile pred [n++show i | i <- [2..]]
src/Text/XML/HaXml/Schema/PrettyHsBoot.hs view
@@ -66,7 +66,7 @@ ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q)-ppFieldId nx = \t-> ppHName . fieldid nx t+ppFieldId nx t = ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc@@ -227,7 +227,7 @@ -- $$ text "data" <+> ppConId nx t <+> text "=" -- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es) --- Possibly we want to declare a really more restrictive type, e.g. +-- Possibly we want to declare a really more restrictive type, e.g. -- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo -- consequently the "restricts" method should do a proper translation, -- not merely an unwrapping.@@ -350,7 +350,7 @@ text "-- instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper $$ text "-- will be declared in module" <+> ppModId nx mod ppSuperExtension nx super grandSupers (t,Nothing) =- vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers))+ vcat (map (ppSuper t . reverse) (drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) =@@ -382,7 +382,7 @@ ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e)-ppElemTypeName nx brack e@OneOf{} = +ppElemTypeName nx brack e@OneOf{} = brack $ ppTypeModifier (elem_modifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e))) <+> hsep (map ppSeq (elem_oneOf e))@@ -440,7 +440,6 @@ | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $- dropWhile pred [(n++show i) | i <- [2..]]+ dropWhile pred [n++show i | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $- dropWhile pred [(n++show i) | i <- [2..]]-+ dropWhile pred [n++show i | i <- [2..]]
src/Text/XML/HaXml/Schema/PrimitiveTypes.hs view
@@ -155,10 +155,13 @@ `onFail` return 0) `apply` ((parseFloat `discard` isNext 'S') `onFail` return 0)+ simpleTypeText (Duration pos 0 0 0 0 0 0) = (if pos then "" else "-")++"P0S" simpleTypeText (Duration pos y m d h n s) =- (if pos then "" else "-")++show y++"Y"++show m++"M"++show d++"D"- ++"T"++show h++"H"++show n++"M"++show s++"S"-+ (if pos then "" else "-")++"P"++showUnit y 'Y'++showUnit m 'M'++showUnit d 'D'++showTime+ where+ showUnit :: (Num a,Eq a,Show a) => a -> Char -> String+ showUnit n u = if n == 0 then "" else show n ++ [u]+ showTime = if (h,n,s) == (0,0,0) then "" else "T"++showUnit h 'H'++showUnit n 'M'++showUnit s 'S' instance SimpleType DateTime where acceptingParser = fmap DateTime (many next) -- acceptingParser = fail "not implemented: simpletype parser for DateTime"
src/Text/XML/HaXml/Schema/Schema.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,+{-# LANGUAGE CPP, FunctionalDependencies, TypeSynonymInstances, ExistentialQuantification #-} module Text.XML.HaXml.Schema.Schema ( SchemaType(..)@@ -32,6 +32,7 @@ , addXMLAttributes ) where +import Control.Monad (void) import Text.ParserCombinators.Poly import Text.Parse @@ -40,7 +41,6 @@ import Text.XML.HaXml.Namespaces (printableName) import Text.XML.HaXml.XmlContent.Parser hiding (Document,Reference) import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))-import Text.XML.HaXml.Schema.PrimitiveTypes import Text.XML.HaXml.Schema.PrimitiveTypes as Prim import Text.XML.HaXml.OneOfN import Text.XML.HaXml.Verbatim@@ -147,7 +147,7 @@ [CString False text ()] toXMLAnyElement :: AnyElement -> [Content ()]-toXMLAnyElement (UnconvertedANY c) = [fmap (const ()) c]+toXMLAnyElement (UnconvertedANY c) = [void c] --toXMLAnyElement (ANYSchemaType x) = [c] toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute]@@ -204,7 +204,7 @@ -- Ensure that all primitive/simple types can also be used as elements. -#define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e $ parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] }+#define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] } SchemaInstance(XsdString) SchemaInstance(Prim.Boolean)@@ -249,4 +249,3 @@ SchemaInstance(Prim.UnsignedShort) SchemaInstance(Prim.UnsignedByte) SchemaInstance(Prim.PositiveInteger)-
src/Text/XML/HaXml/Schema/TypeConversion.hs view
@@ -43,7 +43,7 @@ -> (e:) _ -> id _ -> id- ) $+ ) ( case elem_content e of Nothing -> [] Just (Left _) -> []@@ -98,7 +98,7 @@ where item (Include loc ann) = [XSDInclude (xname loc) (comment ann)] item (Import uri loc ann) = [XSDImport (xname loc)- (fmap xname $+ (xname <$> Map.lookup uri (env_namespace env)) (comment ann)] item (Redefine _ _) = [] -- ignoring redefinitions for now@@ -155,14 +155,14 @@ squeeze xs [] = Just xs complex ct =- let nx = N $ fromMaybe ("errorMissingName") (complex_name ct)+ let nx = N $ fromMaybe "errorMissingName" (complex_name ct) n = XName nx in singleton $ case complex_content ct of c@SimpleContent{} -> case ci_stuff c of Left r ->- RestrictSimpleType n ({-simple-}xname $ "Unimplemented") []+ RestrictSimpleType n ({-simple-}xname "Unimplemented") [] (comment (complex_annotation ct `mappend` ci_annotation c)) Right e ->@@ -176,7 +176,7 @@ c@ComplexContent{} -> case ci_stuff c of Left r ->- RestrictComplexType n ({-complex-}xname $ "Can'tBeRight")+ RestrictComplexType n ({-complex-}xname "Can'tBeRight") (comment (complex_annotation ct `mappend` ci_annotation c)) Right e ->@@ -211,10 +211,10 @@ in ExtendComplexType n ({-supertype-}XName $ extension_base e)- ({-supertype elems-}oldEs)- ({-supertype attrs-}oldAs)- ({-elems-}es)- ({-attrs-}as)+ {-supertype elems-}oldEs+ {-supertype attrs-}oldAs+ {-elems-}es+ {-attrs-}as ({-fwddecl-}if myLoc/=supLoc then Just (xname supLoc) else Nothing) ({-abstract supertype-}@@ -229,14 +229,15 @@ `mappend` extension_annotation e)) c@ThisType{} | complex_abstract ct -> let myLoc = fromMaybe "NUL"- (Map.lookup nx (env_typeloc env)) in+ (Map.lookup nx (env_typeloc env)) in ElementsAttrsAbstract n {-all instance types: -}- (map (\ (x,loc)->(XName x,if loc/=myLoc- then Just (xname loc)- else Nothing))- $ fromMaybe []- $ Map.lookup nx (env_extendty env))+ (case Map.lookup nx (env_extendty env) of+ Nothing -> []+ Just xs -> map (\ (x,loc)->(XName x,if loc/=myLoc+ then Just (xname loc)+ else Nothing)) xs+ ) (comment (complex_annotation ct)) c@ThisType{} | otherwise -> let (es,as) = particleAttrs (ci_thistype c)@@ -256,8 +257,8 @@ --I'm pretty sure a topElementDecl can't be abstract... let (es,as) = contentInfo (elem_content ed) in [ ElementsAttrs ({-name-}xname $ theName n)- ({-elems-}es)- ({-attrs-}as)+ {-elems-}es+ {-attrs-}as (comment (elem_annotation ed)) , ElementOfType $ elementDecl ed -- Element{ elem_name = xname (theName n)@@ -279,11 +280,13 @@ ElementAbstractOfType (XName nm) (checkXName s t)- (map (\ (x,loc)->(XName x,if loc/=myLoc- then Just (xname loc)- else Nothing))- $ fromMaybe []- $ Map.lookup nm (env_substGrp env))+ (case Map.lookup nm (env_substGrp env) of+ Nothing -> []+ Just xs ->+ map (\ (x,loc)->(XName x,+ if loc/=myLoc+ then Just (xname loc)+ else Nothing)) xs) (comment (elem_annotation ed)) Just t | otherwise -> singleton $ ElementOfType $ elementDecl ed@@ -342,10 +345,10 @@ Left st@Primitive{} -> xname "SomethingPrimitive" Left st@Restricted{} -> (\x-> maybe x xname (simple_name st)) $- (maybe (xname "GiveUp")- XName $- restrict_base $- simple_restriction st)+ maybe (xname "GiveUp")+ XName+ (restrict_base $+ simple_restriction st) Left st@ListOf{} -> xname "SomethingListy" Left st@UnionOf{} -> xname "SomethingUnionLike" Right c@ComplexType{} -> maybe (localTypeExp ed{elem_content=Nothing})@@ -354,13 +357,13 @@ | otherwise = case elem_nameOrRef ed of Left n -> xname $ theName n- Right _ -> xname $ "unknownElement"+ Right _ -> xname "unknownElement" attributeDecl :: XSD.AttributeDecl -> [Haskell.Attribute] attributeDecl ad = case attr_nameOrRef ad of Left n -> singleton $ Attribute (xname $ theName n)- (maybe (maybe (xname $ "String")+ (maybe (maybe (xname "String") -- guess at an attribute typename? --(error "XSD.attributeDecl->") nameOfSimple@@ -385,7 +388,7 @@ group :: XSD.Group -> [Haskell.Decl] group g = case group_nameOrRef g of- Left n -> let ({-highs,-}es) = choiceOrSeq (fromMaybe (error "XSD.group")+ Left n -> let {-highs,-}es = choiceOrSeq (fromMaybe (error "XSD.group") (group_stuff g)) in {-highs ++-} singleton $ Haskell.Group (xname n)@@ -435,10 +438,10 @@ -- If an ANY element is part of a choice, ensure it is the last part. anyToEnd :: [[Haskell.Element]] -> [[Haskell.Element]] anyToEnd = go Nothing- where go _ (e@[AnyElem{}]:[]) = e:[]+ where go _ [e@[AnyElem{}]] = [e] go _ (e@[AnyElem{}]:es) = go (Just e) es go Nothing [] = []- go (Just e) [] = e:[]+ go (Just e) [] = [e] go m (e:es) = e:go m es contentInfo :: Maybe (Either SimpleType ComplexType)@@ -496,27 +499,23 @@ ,OrderedBoundsMinExcl ,OrderedBoundsMaxIncl ,OrderedBoundsMaxExcl] ]- in if null occurs then []- else [Haskell.RangeR (foldl consolidate (Occurs Nothing Nothing) occurs)- (comment $ foldr mappend mempty- [ ann | (_,ann,_) <- occurs])]+ in [Haskell.RangeR (foldl consolidate (Occurs Nothing Nothing) occurs)+ (comment $ mconcat [ ann | (_,ann,_) <- occurs]) | null occurs] ) ++ [ Haskell.Pattern v (comment ann) | (Facet UnorderedPattern ann v _) <- facets ] ++ (let enum = [ (v,comment ann) | (Facet UnorderedEnumeration ann v _) <- facets ]- in if null enum then []- else [Haskell.Enumeration enum]+ in [Haskell.Enumeration enum | null enum] ) ++ (let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets , f `elem` [UnorderedLength ,UnorderedMaxLength ,UnorderedMinLength] ]- in if null occurs then []- else [Haskell.StrLength- (foldl consolidate (Occurs Nothing Nothing) occurs)- (comment $ foldr mappend mempty [ ann | (_,ann,_) <- occurs])]+ in [Haskell.StrLength+ (foldl consolidate (Occurs Nothing Nothing) occurs)+ (comment $ mconcat [ ann | (_,ann,_) <- occurs]) | null occurs] ) singleton :: a -> [a]@@ -527,11 +526,11 @@ consolidate (Occurs min max) (OrderedBoundsMinIncl,_,n) = Occurs (Just (read n)) max consolidate (Occurs min max) (OrderedBoundsMinExcl,_,n) =- Occurs (Just ((read n)+1)) max+ Occurs (Just (read n +1)) max consolidate (Occurs min max) (OrderedBoundsMaxIncl,_,n) = Occurs min (Just (read n)) consolidate (Occurs min max) (OrderedBoundsMaxExcl,_,n) =- Occurs min (Just ((read n)-1))+ Occurs min (Just (read n -1)) consolidate (Occurs min max) (UnorderedLength,_,n) = Occurs (Just (read n)) (Just (read n)) consolidate (Occurs min max) (UnorderedMinLength,_,n) =
src/Text/XML/HaXml/Schema/XSDTypeModel.hs view
@@ -102,12 +102,12 @@ deriving (Eq,Show) data ComplexItem = SimpleContent { ci_annotation :: Annotation- , ci_stuff :: (Either Restriction1 Extension)+ , ci_stuff :: Either Restriction1 Extension } | ComplexContent { ci_annotation :: Annotation , ci_mixed :: Bool- , ci_stuff :: (Either Restriction1 Extension)+ , ci_stuff :: Either Restriction1 Extension } | ThisType { ci_thistype :: ParticleAttrs@@ -311,4 +311,3 @@ instance Semigroup Schema where s <> t = s{ schema_items = schema_items s ++ schema_items t }-
src/Text/XML/HaXml/ShowXmlLazy.hs view
@@ -146,8 +146,8 @@ text "<" <> qname n <+> fsep (map attribute as) , text "/>") carryelem (Elem n as cs) c--- | any isText cs = ( c <> element e, empty)- | otherwise = let (cs0,d0) = carryscan carrycontent cs (text ">")+{- | any isText cs = ( c <> element e, empty)+ | otherwise -} = let (cs0,d0) = carryscan carrycontent cs (text ">") in ( c <> text "<" <> qname n <+> fsep (map attribute as) $$@@ -333,4 +333,3 @@ containsDoubleQuote evs = any csq evs where csq (EVString s) = '"' `elem` s csq _ = False-
src/Text/XML/HaXml/TypeMapping.hs view
@@ -202,11 +202,11 @@ DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht]))) where macrosFirst :: [MarkupDecl] -> [MarkupDecl]- macrosFirst decls = concat [p, p'] where (p, p') = partition f decls- f (Entity _) = True- f _ = False+ macrosFirst decls = p ++ p' where (p, p') = partition f decls+ f (Entity _) = True+ f _ = False toplevel ht@(Defined _ _ _) = N $ showHType ht "-XML"- toplevel ht@_ = N $ showHType ht ""+ toplevel ht = N $ showHType ht "" c0 = False h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl] -- toplevel? history history remainingwork result@@ -261,13 +261,13 @@ showHType (Prim _ t) = showString t showHType String = showString "string" showHType (Defined s fv _)- = showString s . ((length fv > 0) ? (showChar '-'))+ = showString s . ((length fv > 0) ? showChar '-') . foldr (.) id (intersperse (showChar '-') (map showHType fv)) flatConstr :: Constr -> ShowS flatConstr (Constr s fv _)- = showString s . ((length fv > 0) ? (showChar '-'))+ = showString s . ((length fv > 0) ? showChar '-') . foldr (.) id (intersperse (showChar '-') (map showHType fv)) outerHtExpr :: HType -> CP@@ -279,7 +279,7 @@ innerHtExpr :: HType -> Modifier -> CP innerHtExpr (Prim _ t) m = TagName (N t) m-innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m+innerHtExpr (Tuple hts) m = Seq (map (`innerHtExpr` None) hts) m innerHtExpr ht@(Defined _ _ _) m = -- CPPE (showHType ht "") (outerHtExpr ht) TagName (N ('%': showHType ht ";")) m -- ***HACK!!!***
src/Text/XML/HaXml/Validate.hs view
@@ -11,7 +11,7 @@ import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o) import Text.XML.HaXml.XmlContent (attr2str) import Data.Maybe (fromMaybe,isNothing,fromJust)-import Data.List (intersperse,nub,(\\))+import Data.List (intercalate,nub,(\\)) import Data.Char (isSpace) #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)@@ -98,12 +98,12 @@ valid (Elem name attrs contents) = -- is the element defined in the DTD? let spec = lookupFM (elements dtd) name in- (isNothing spec) `gives` ("Element <"++qname name++"> not known.")+ isNothing spec `gives` ("Element <"++qname name++"> not known.") -- is each attribute mentioned only once? ++ (let dups = duplicates (map (qname . fst) attrs) in not (null dups) `gives` ("Element <"++qname name++"> has duplicate attributes: "- ++concat (intersperse "," dups)++"."))+ ++intercalate "," dups++".")) -- does each attribute belong to this element? value is in range? ++ concatMap (checkAttr name) attrs -- are all required attributes present?@@ -124,7 +124,7 @@ EnumeratedType e -> case e of Enumeration es ->- (not (attval `Prelude.elem` es)) `gives`+ (attval `notElem` es) `gives` ("Value \""++attval++"\" of attribute \"" ++qname attr++"\" in element <"++qname elm ++"> is not in the required enumeration range: "@@ -133,7 +133,7 @@ _ -> [] checkRequired elm attrs req =- (not (req `Prelude.elem` map fst attrs)) `gives`+ (req `notElem` map fst attrs) `gives` ("Element <"++qname elm++"> requires the attribute \""++qname req ++"\" but it is missing.") @@ -151,7 +151,7 @@ ++"elements beyond its content spec."]) checkMixed elm permitted (CElem (Elem name _ _) _)- | not (name `Prelude.elem` permitted) =+ | name `notElem` permitted = ["Element <"++qname elm++"> contains an element <"++qname name ++"> but should not."] checkMixed _elm _permitted _ = []@@ -260,7 +260,7 @@ badIds = duplicates (map (\(CString _ s _)->s) idElems) in not (null badIds) `gives` ("These attribute values of type ID are not unique: "- ++concat (intersperse "," badIds)++".")+ ++intercalate "," badIds++".") cpError :: QName -> CP -> [String]@@ -270,9 +270,9 @@ display :: CP -> String display (TagName name mod) = qname name ++ modifier mod-display (Choice cps mod) = "(" ++ concat (intersperse "|" (map display cps))+display (Choice cps mod) = "(" ++ intercalate "|" (map display cps) ++ ")" ++ modifier mod-display (Seq cps mod) = "(" ++ concat (intersperse "," (map display cps))+display (Seq cps mod) = "(" ++ intercalate "," (map display cps) ++ ")" ++ modifier mod modifier :: Modifier -> String@@ -282,7 +282,7 @@ modifier Plus = "+" duplicates :: Eq a => [a] -> [a]-duplicates xs = xs \\ (nub xs)+duplicates xs = xs \\ nub xs qname :: QName -> String qname n = printableName n
src/Text/XML/HaXml/Verbatim.hs view
@@ -58,7 +58,7 @@ verbatim :: a -> String instance (Verbatim a) => Verbatim [a] where- verbatim = concat . (map verbatim)+ verbatim = concatMap verbatim instance Verbatim Char where verbatim c = [c]@@ -77,10 +77,10 @@ instance Verbatim (Element i) where verbatim (Elem nam att []) = "<" ++ qname nam- ++ (concat . (map verbAttr)) att+ ++ concatMap verbAttr att ++ "/>" verbatim (Elem nam att cont) = "<" ++ qname nam- ++ (concat . (map verbAttr)) att+ ++ concatMap verbAttr att ++ ">" ++ verbatim cont ++ "</" ++ qname nam ++ ">" @@ -99,4 +99,3 @@ verbAttr :: Attribute -> String verbAttr (n, AttValue v) = " " ++ qname n ++ "=\"" ++ verbatim v ++ "\""-
src/Text/XML/HaXml/Wrappers.hs view
@@ -33,10 +33,10 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-" ++ version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://projects.haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://projects.haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -66,7 +66,7 @@ hFlush o where- onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn+ onContent :: FilePath -> CFilter Posn -> Document Posn -> Document Posn onContent file filter (Document p s e m) = case filter (CElem e (posInNewCxt file Nothing)) of [CElem e' _] -> Document p s e' m
src/Text/XML/HaXml/XmlContent.hs view
@@ -4,7 +4,7 @@ -- -- If you are starting with an XML DTD, use HaXml's tool DtdToHaskell -- to generate both the Haskell types and the corresponding instances.--- +-- -- If you are starting with a set of Haskell datatypes, use DrIFT to -- derive instances of this class for you: -- http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT@@ -168,7 +168,7 @@ parseContents = let result = runParser p [] -- for type of result only p = case (toHType . head . (\ (Right x)->x) . fst) result of- (Prim "Char" _) -> fmap (map xFromChar) $ text+ (Prim "Char" _) -> map xFromChar <$> text _ -> many parseContents in p -- comments, PIs, etc, are skipped in the individual element parser.
src/Text/XML/HaXml/XmlContent/Haskell.hs view
@@ -175,7 +175,7 @@ instance XmlContent Char where -- NOT in a string toContents c = [CElem (Elem (N "char") [mkAttr "value" [c]] []) ()]- parseContents = do { (Elem _ [(N "value",(AttValue [Left [c]]))] [])+ parseContents = do { (Elem _ [(N "value",AttValue [Left [c]])] []) <- element ["char"] ; return c }@@ -216,7 +216,7 @@ (CRef r pos: cs) -> Failure cs ("Expected a <list-...>, but found a ref " ++verbatim r++" at\n"++ show pos)- (_:cs) -> ((\ (P p)-> p) parseContents) cs -- skip comments etc.+ (_:cs) -> (\ (P p)-> p) parseContents cs -- skip comments etc. [] -> Failure [] "Ran out of input XML whilst secondary parsing" ) @@ -239,9 +239,9 @@ toContents v@(Right ab) = [mkElemC (showConstr 1 (toHType v)) (toContents ab)] parseContents =- (inElementWith (flip isPrefixOf) "Left" $ fmap Left parseContents)+ inElementWith (flip isPrefixOf) "Left" (fmap Left parseContents) `onFail`- (inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents)+ inElementWith (flip isPrefixOf) "Right" (fmap Right parseContents) -- do{ e@(Elem t [] _) <- element ["Left","Right"] -- ; case t of
src/Text/XML/HaXml/XmlContent/Parser.hs view
@@ -13,7 +13,7 @@ -- This unified class interface replaces two previous (somewhat similar) -- classes: Haskell2Xml and Xml2Haskell. There was no real reason to have -- separate classes depending on how you originally defined your datatypes.--- However, some instances for basic types like lists will depend on which +-- However, some instances for basic types like lists will depend on which -- direction you are using. See Text.XML.HaXml.XmlContent and -- Text.XML.HaXml.XmlContent.Haskell. @@ -67,7 +67,7 @@ , ANYContent(..) ) where ---import System.IO+import Control.Monad (void) import Data.Maybe (catMaybes) import Data.Char (chr, isSpace) @@ -609,7 +609,7 @@ str2attr :: String -> AttValue str2attr s = let f t =- let (l,r) = span (\c-> not (elem c "\"&<>'")) t+ let (l,r) = span (`notElem` "\"&<>'") t in if null r then [Left l] else Left l: Right (g (head r)): f (tail r) g '"' = RefEntity "quot"@@ -652,8 +652,8 @@ | UnConverted [Content Posn] instance Show ANYContent where- show (UnConverted c) = "UnConverted " ++ (show $ map verbatim c)- show (ANYContent a) = "ANYContent " ++ (show a)+ show (UnConverted c) = "UnConverted " ++ show (map verbatim c)+ show (ANYContent a) = "ANYContent " ++ show a instance Eq ANYContent where a == b = show a == show b@@ -673,14 +673,14 @@ hx = toHType x instance (XmlContent a) => XmlContent (List1 a) where toContents (NonEmpty xs) = concatMap toContents xs- parseContents = fmap NonEmpty $ many1 parseContents+ parseContents = NonEmpty <$> many1 parseContents instance HTypeable ANYContent where toHType _ = Prim "ANYContent" "ANY" instance XmlContent ANYContent where toContents (ANYContent a) = toContents a- toContents (UnConverted s) = map (fmap (const ())) s- parseContents = P (\cs -> Success [] (UnConverted cs))+ toContents (UnConverted s) = map void s+ parseContents = P (Success [] . UnConverted) ------------------------------------------------------------------------ --
src/Text/XML/HaXml/Xtract/Combinators.hs view
@@ -21,20 +21,20 @@ -- | lift an ordinary content filter to a double filter. local,global :: CFilter i -> DFilter i-local f = \_xml sub-> f sub-global f = \ xml _sub-> f xml+local f _xml sub = f sub+global f xml _sub = f xml -- | drop a double filter to an ordinary content filter. -- (permitting interior access to document root) dfilter :: DFilter i -> CFilter i-dfilter f = \xml-> f xml xml+dfilter f xml = f xml xml -- | drop a double filter to an ordinary content filter. -- (Where interior access to the document root is not needed, the -- retaining pointer to the outer element can be pruned away. -- 'cfilter' is more space-efficient than 'dfilter' in this situation.) cfilter :: DFilter i -> CFilter i-cfilter f = \xml -> f undefined xml+cfilter f = f undefined --cfilter f = \xml-> flip f xml -- (case xml of -- CElem (Elem n as cs) i -> CElem (Elem n [] []) i@@ -42,12 +42,12 @@ -- | lift a CFilter combinator to a DFilter combinator liftLocal, liftGlobal :: (CFilter i->CFilter i) -> (DFilter i->DFilter i)-liftLocal ff = \df-> \xml sub-> (ff (df xml)) sub-liftGlobal ff = \df-> \xml _sub-> (ff (df xml)) xml+liftLocal ff df xml sub = ff (df xml) sub+liftGlobal ff df xml _sub = ff (df xml) xml -- | lifted composition over double filters. o :: DFilter i -> DFilter i -> DFilter i-g `o` f = \xml-> concatMap (g xml) . (f xml)+g `o` f = \xml-> concatMap (g xml) . f xml -- | lifted choice. (|>|) :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c])@@ -67,8 +67,8 @@ -- | lifted unit and zero. keep, none :: DFilter i-keep = \_xml sub-> [sub] -- local C.keep-none = \_xml _sub-> [] -- local C.none+keep _xml sub = [sub] -- local C.keep+none _xml _sub = [] -- local C.none children, elm, txt :: DFilter i children = local C.children@@ -76,11 +76,11 @@ txt = local C.txt applypred :: CFilter i -> DFilter i -> CFilter i-applypred f p = \xml-> (const f `with` p) xml xml+applypred f p xml = (const f `with` p) xml xml iffind :: String -> (String -> DFilter i) -> DFilter i -> DFilter i iffind key yes no xml c@(CElem (Elem _ as _) _) =- case (lookup (N key) as) of+ case lookup (N key) as of Nothing -> no xml c (Just v@(AttValue _)) -> yes (show v) xml c iffind _key _yes no xml other = no xml other@@ -90,7 +90,7 @@ ifTxt _yes no xml c = no xml c cat :: [a->b->[c]] -> (a->b->[c])-cat fs = \xml sub-> concat [ f xml sub | f <- fs ]+cat fs xml sub = concat [ f xml sub | f <- fs ] (/>) :: DFilter i -> DFilter i -> DFilter i f /> g = g `o` children `o` f
src/Text/XML/HaXml/Xtract/Parse.hs view
@@ -238,11 +238,10 @@ [ do s <- string symbol "*" return (local (C.tagWith (s `isPrefixOf`)))- , do s <- string- return (local (C.tag s))+ , local . C.tag <$> string , do symbol "*" s <- string- return (local (C.tagWith (((reverse s) `isPrefixOf`) . reverse)))+ return (local (C.tagWith ((reverse s `isPrefixOf`) . reverse))) , do symbol "*" return (local C.elm) ]@@ -251,13 +250,13 @@ xquery :: [DFilter i->DFilter i] -> DFilter i -> XParser (DFilter i) xquery cxt q1 = oneOf [ do symbol "/"- ( do symbol "@"- attr <- string- return (D.iffind attr (\s->local (C.literal s)) D.none `D.o` q1)- `onFail`- tquery ((q1 D./>):cxt) )+ do symbol "@"+ attr <- string+ return (D.iffind attr (local . C.literal) D.none `D.o` q1)+ `onFail`+ tquery ((q1 D./>):cxt) , do symbol "//"- tquery ((\q2-> (liftLocal C.multi) q2+ tquery ((\q2-> liftLocal C.multi q2 `D.o` local C.children `D.o` q1):cxt) , do symbol "+" q2 <- tquery cxt@@ -324,24 +323,24 @@ quote s2 <- string quote- return ((iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none)+ return (iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none `D.o` q) , do cmp <- op (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?- return ((iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none)+ return (iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none) D.none)- D.none) `D.o` q)+ D.none `D.o` q) , do cmp <- nop n <- number- return ((iffn (\s->if cmp (read s) n then D.keep else D.none) D.none)+ return (iffn (\s->if cmp (read s) n then D.keep else D.none) D.none `D.o` q) , do cmp <- nop (q2,iffn2) <- wattribute -- q2 unused? is this a mistake?- return ((iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep+ return (iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep else D.none) D.none)- D.none) `D.o` q)- , do return ((a `D.o` q))+ D.none `D.o` q)+ , do return (a `D.o` q) ] wattribute :: XParser (DFilter i, (String->DFilter i)->DFilter i->DFilter i)@@ -368,8 +367,7 @@ simpleindex :: XParser ([a]->[a]) simpleindex = oneOf [ do n <- number- r <- rrange n- return r+ rrange n , do symbol "$" return (C.keep . last) ]
src/tools/DtdToHaskell.hs view
@@ -28,10 +28,10 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -50,9 +50,10 @@ else openFile outf WriteMode ) >>= \o-> let (DTD name _ markup) = (getDtd . dtdParse inf) content decls = (nub . dtd2TypeDef) markup- realname = if outf/="-" then mangle (trim outf)- else if null (localName name) then mangle (trim inf)- else mangle (localName name)+ realname+ | outf /= "-" = mangle (trim outf)+ | null (localName name) = mangle (trim inf)+ | otherwise = mangle (localName name) in do hPutStrLn o ("module "++realname ++" where\n\nimport Text.XML.HaXml.XmlContent"@@ -69,7 +70,7 @@ getDtd :: Maybe t -> t getDtd (Just dtd) = dtd-getDtd (Nothing) = error "No DTD in this document"+getDtd Nothing = error "No DTD in this document" trim :: [Char] -> [Char] trim name | '/' `elem` name = (trim . tail . dropWhile (/='/')) name
src/tools/FpMLToHaskell.hs view
@@ -15,7 +15,7 @@ import Control.Exception as E import System.Directory import Data.List-import Data.Maybe (fromMaybe,catMaybes)+import Data.Maybe (fromMaybe,mapMaybe) import Data.Function (on) import Text.XML.HaXml (version)@@ -46,12 +46,12 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "Usage: FpMLToHaskell xsdDir haskellDir"- putStrLn $ " -- The results go into haskelldir/Data/FpML/file0.hs etc"- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "Usage: FpMLToHaskell xsdDir haskellDir"+ putStrLn " -- The results go into haskelldir/Data/FpML/file0.hs etc"+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case args of [xsddir,hdir]-> do files <- fmap (filter (".xsd" `isSuffixOf`))@@ -59,21 +59,21 @@ let newdirs = map (\file->hdir++"/"++dirOf (fpml file)) files mapM_ (\newdir -> do createDirectoryIfMissing True newdir) newdirs return (xsddir- ,map (\f-> (f, hdir++"/"++(reslash (fpml f))++".hs")) files)+ ,map (\f-> (f, hdir++"/"++reslash (fpml f)++".hs")) files) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" xsdDir haskellDir") exitFailure where reslash = map (\c-> case c of '.'->'/'; _->c)- dirOf = concat . intersperse "/" . init . wordsBy' '.'+ dirOf = intercalate "/" . init . wordsBy' '.' wordsBy' c s = let (a,b) = span (/=c) s in if null b then [a] else a: wordsBy' c (tail b) main ::IO () main = do (dir,files) <- argDirsToFiles- deps <- flip mapM files (\ (inf,_outf)-> do- hPutStrLn stdout $ "Reading "++inf+ deps <- forM files (\ (inf,_outf)-> do+ putStrLn $ "Reading "++inf thiscontent <- readFileUTF8 (dir++"/"++inf) let d@Document{} = resolveAllNames qualify . either (error . ("not XML:\n"++)) id@@ -83,11 +83,11 @@ (Left msg,_) -> do hPutStrLn stderr msg return ([], undefined) (Right v,[]) -> return (Env.gatherImports v, v)- (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"- hPutStrLn stdout $ inf- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ (Right v,_) -> do putStrLn "Parse incomplete!"+ putStrLn inf+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" return ([],v) ) let filedeps :: [[((FilePath,FilePath),([(FilePath,Maybe String)],Schema))]]@@ -97,9 +97,9 @@ (zip files deps) -- a single supertype environment, closed over all modules supertypeEnv :: Environment- supertypeEnv = foldr (\fs e->- foldr (\((inf,_),(_,v))-> mkEnvironment inf v)- e fs)+ supertypeEnv = foldr (flip (foldr+ (\ ((inf, _), (_, v)) ->+ mkEnvironment inf v))) emptyEnv filedeps adjust :: Environment -> Environment adjust env = env{ env_extendty = env_extendty supertypeEnv@@ -135,15 +135,13 @@ (\d-> fst3 $ fromMaybe (error "FME") $ lookup d environs)- in flip map cyclic- (\((inf,outf),(_,v))->- (inf,(adjust $ mkEnvironment inf v- $ jointEnv- ,outf- ,v)- )- )- flip mapM_ environs (\ (inf,(env,outf,v))-> do+ in flip map cyclic $+ \((inf,outf),(_,v))->+ (inf,(adjust $ mkEnvironment inf v jointEnv+ ,outf+ ,v)+ )+ forM_ environs (\ (inf,(env,outf,v))-> do o <- openFile outf WriteMode hb <- openFile (bootf outf) WriteMode hSetEncoding o utf8@@ -152,9 +150,9 @@ haskell = Haskell.mkModule inf v decls doc = ppModule fpmlNameConverter haskell docboot = HsBoot.ppModule fpmlNameConverter haskell- hPutStrLn stdout $ "Writing "++outf+ putStrLn $ "Writing "++outf hPutStrLn o $ render doc- hPutStrLn stdout $ "Writing "++(bootf outf)+ putStrLn $ "Writing "++bootf outf hPutStrLn hb $ render docboot hFlush o hFlush hb@@ -189,9 +187,9 @@ where -- walk :: [b] -> b -> [[b]] walk acc t = if name' t `elem` map name' acc then [acc]- else concatMap (walk (t:acc)) (catMaybes . map env $ deps t)+ else concatMap (walk (t:acc)) (mapMaybe env $ deps t) minimal acc c = concatMap (prune c) acc- prune c c' = if map name' c `isProperSubsetOf` map name' c' then [] else [c']+ prune c c' = [c' | not (map name' c `isProperSubsetOf` map name' c')] isSubsetOf a b = all (`elem`b) a setEq a b = a`isSubsetOf`b && b`isSubsetOf`a isProperSubsetOf a b = a`isSubsetOf`b && not (b`isSubsetOf`a)@@ -206,9 +204,8 @@ targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"- else case lookup (N "targetNamespace") attrs of- Nothing -> "ERROR! no targetNamespace specified"- Just atv -> show atv+ else maybe "ERROR! no targetNamespace specified" show+ (lookup (N "targetNamespace") attrs) -- | The XSD Namespace. xsdSchema :: QName@@ -220,4 +217,4 @@ readFileUTF8 file = do h <- openFile file ReadMode (do hSetEncoding h utf8- hGetContents h) `E.onException` (hClose h)+ hGetContents h) `E.onException` hClose h
src/tools/MkOneOf.hs view
@@ -1,7 +1,7 @@ module Main where import Prelude hiding (max)-import System.Exit (exitWith,ExitCode(..))+import System.Exit (exitSuccess) import System.Environment (getArgs) import Data.Char (isDigit) import System.IO (hFlush,stdout)@@ -13,19 +13,19 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 1 -> do n <- saferead (head args) putStrLn ("module Text.XML.HaXml."++constructor 1 n++" where\n")- putStrLn ("import Text.XML.HaXml.XmlContent\n")+ putStrLn "import Text.XML.HaXml.XmlContent\n" putStrLn (mkOneOf n) 2 -> do n <- saferead (args!!0) m <- saferead (args!!1)- putStrLn ("module Text.XML.HaXml.OneOfN where\n")- putStrLn ("import Text.XML.HaXml.XmlContent\n")+ putStrLn "module Text.XML.HaXml.OneOfN where\n"+ putStrLn "import Text.XML.HaXml.XmlContent\n" mapM_ (putStrLn . mkOneOf) [n..m] _ -> error "Usage: MkOneOf n [m]" hFlush stdout@@ -74,8 +74,7 @@ constructor n m = ordinal n ++"Of" ++ show m ordinal :: Int -> String-ordinal n | n <= 20 = ordinals!!n-ordinal n | otherwise = "Choice"++show n+ordinal n = if n <= 20 then ordinals!!n else "Choice"++show n ordinals :: [String] ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight"@@ -84,8 +83,8 @@ ---- variable names ---- variables :: [String]-variables = [ v:[] | v <- ['a'..'y']]- ++ [ v:w:[] | v <- ['a'..'z'], w <- ['a'..'z']]+variables = [ [v] | v <- ['a'..'y']]+ ++ [ [v,w] | v <- ['a'..'z'], w <- ['a'..'z']] ---- simple pretty-printing ---- @@ -106,6 +105,7 @@ ---- safe integer parsing ---- saferead :: String -> IO Int-saferead s | all isDigit s = return (read s)-saferead s | otherwise = error ("expected a number on the commandline, "- ++"but got \""++s++"\" instead")+saferead s = if all isDigit s+ then return (read s)+ else error ("expected a number on the commandline, "+ ++"but got \""++s++"\" instead")
src/tools/XsdToHaskell.hs view
@@ -37,10 +37,10 @@ args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version- exitWith ExitSuccess+ exitSuccess when ("--help" `elem` args) $ do- putStrLn $ "See http://haskell.org/HaXml"- exitWith ExitSuccess+ putStrLn "See http://haskell.org/HaXml"+ exitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-")@@ -64,18 +64,18 @@ in do case runParser schema [docContent (posInNewCxt inf Nothing) d] of (Left msg,_) -> hPutStrLn stderr msg- (Right v,[]) -> do hPutStrLn stdout $ "Parse Success!"- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ (Right v,[]) -> do putStrLn "Parse Success!"+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" let decls = convert (mkEnvironment inf v emptyEnv) v haskl = Haskell.mkModule inf v decls doc = ppModule simpleNameConverter haskl hPutStrLn o $ render doc- (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"- hPutStrLn stdout $ "\n-----------------\n"- hPutStrLn stdout $ show v- hPutStrLn stdout $ "\n-----------------\n"+ (Right v,_) -> do putStrLn "Parse incomplete!"+ putStrLn "\n-----------------\n"+ putStrLn $ show v+ putStrLn "\n-----------------\n" hFlush o @@ -115,9 +115,8 @@ targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"- else case lookup (N "targetNamespace") attrs of- Nothing -> "ERROR! no targetNamespace specified"- Just atv -> show atv+ else maybe "ERROR! no targetNamespace specified" show+ (lookup (N "targetNamespace") attrs) xsdSchema :: QName xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"})