diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,16 @@ +## 1.25.14 (2024-12-12) +- fix inaccuracies in haskell generation code (#17 from @SiriusCourses): + - Fix mkNamespace for case when QName is recognized at root element + - Fix QName parser to recognize names with namespaces + - Prevent multiple declarations after type lifting hoist + - Inject groups from reference at topElementDecl + - Fix bug unexcaped module name in generated haskell code + - Add to Environment deriving for Show and Eq for simpler debug + - Fix name with dashes for simpleType +- PrettyH*: Add missing pattern match to ppComment (#24 from @e-rk) +- Allow base-4.20 and filepath-1.5; bump CI to GHC 9.8 (#21, @andreasabel) +- allow base-4.22 for ghc-9.12 (#23, @juhp) + ## 1.25.13 (2023-07-13) - correct zero time duration P0S to PT0S (@dten, #16) - allow ghc-9.6 base (@andreasabel, #15) diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,7 +1,6 @@ cabal-version: 1.18 name: HaXml -version: 1.25.13 -x-revison: 1 +version: 1.25.14 license: LGPL-2.1 license-files: COPYRIGHT, LICENCE-GPL, LICENCE-LGPL @@ -18,8 +17,9 @@ extra-doc-files: Changelog.md README tested-with: - GHC ==9.6.2 - || ==9.4.5 + GHC ==9.8.2 + || ==9.6.6 + || ==9.4.8 || ==9.2.8 || ==9.0.2 || ==8.10.7 @@ -83,10 +83,10 @@ Text.XML.HaXml.Schema.Schema hs-source-dirs: src build-depends: - base >= 4.3.1.0 && < 4.19, + base >= 4.3.1.0 && < 4.22, bytestring >= 0.9.1.10 && < 0.13, - containers >= 0.4.0.0 && <0.7, - filepath >= 1.2.0.0 && <1.5, + containers >= 0.4.0.0 && <0.8, + filepath >= 1.2.0.0 && <1.6, pretty >= 1.0.1.2 && <1.2, random >= 1.0 && <1.3, polyparse >= 1.12.1 && <1.14 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/src/Text/XML/HaXml/Namespaces.hs b/src/Text/XML/HaXml/Namespaces.hs --- a/src/Text/XML/HaXml/Namespaces.hs +++ b/src/Text/XML/HaXml/Namespaces.hs @@ -171,6 +171,8 @@ mkNamespace :: Attribute -> Namespace mkNamespace (N n, atv) = let (_,':':nm) = span (/=':') n in Namespace{nsPrefix=nm,nsURI=show atv} + mkNamespace (q@(QN (Namespace{ nsURI="" }) n), atv) = + Namespace{nsPrefix=n,nsURI=show atv} matching :: (String->Bool) -> [Attribute] -> [Attribute] matching p = filter (p . printableName . fst) -- diff --git a/src/Text/XML/HaXml/Parse.hs b/src/Text/XML/HaXml/Parse.hs --- a/src/Text/XML/HaXml/Parse.hs +++ b/src/Text/XML/HaXml/Parse.hs @@ -172,7 +172,20 @@ -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName -qname = fmap N name +qname = do + (p,tok) <- next + case tok of + TokName s -> case split ':' s of + [one] -> return $ N s + [ns,elem_name] -> return $ QN (Namespace ns "") elem_name + _ -> report fail "a name" p tok + TokError _ -> report failBad "a name" p tok + _ -> report fail "a name" p tok + where + split :: Char -> String -> [String] + split c xs = case break (==c) xs of + (ls, "") -> [ls] + (ls, x:rs) -> ls : split c rs -- | Return just a name, e.g. element name, attribute name. name :: XParser Name diff --git a/src/Text/XML/HaXml/ParseLazy.hs b/src/Text/XML/HaXml/ParseLazy.hs --- a/src/Text/XML/HaXml/ParseLazy.hs +++ b/src/Text/XML/HaXml/ParseLazy.hs @@ -176,7 +176,20 @@ -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName -qname = fmap N name +qname = do + (p,tok) <- next + case tok of + TokName s -> case split ':' s of + [one] -> return $ N s + [ns,elem_name] -> return $ QN (Namespace ns "") elem_name + _ -> report fail "a name" p tok + TokError _ -> report failBad "a name" p tok + _ -> report fail "a name" p tok + where + split :: Char -> String -> [String] + split c xs = case break (==c) xs of + (ls, "") -> [ls] + (ls, x:rs) -> ls : split c rs -- | Return just a name, e.g. element name, attribute name. name :: XParser Name diff --git a/src/Text/XML/HaXml/Schema/Environment.hs b/src/Text/XML/HaXml/Schema/Environment.hs --- a/src/Text/XML/HaXml/Schema/Environment.hs +++ b/src/Text/XML/HaXml/Schema/Environment.hs @@ -56,6 +56,7 @@ , env_substGrp :: Map QName [(QName,FilePath)] -- ^ substitution groups , env_typeloc :: Map QName FilePath -- ^ where type is defined } + deriving (Show, Eq) -- | An empty environment of XSD type mappings. emptyEnv :: Environment diff --git a/src/Text/XML/HaXml/Schema/NameConversion.hs b/src/Text/XML/HaXml/Schema/NameConversion.hs --- a/src/Text/XML/HaXml/Schema/NameConversion.hs +++ b/src/Text/XML/HaXml/Schema/NameConversion.hs @@ -68,7 +68,7 @@ | map toLower c == "integer" = "Xsd.Integer" | map toLower c == "boolean" = "Xsd.Boolean" | map toLower c == "decimal" = "Xsd.Decimal" - | otherwise = first toUpper m++"."++first toUpper (map escape c) + | otherwise = first toUpper (map escape m)++"."++first toUpper (map escape c) mkConid more = mkConid [concat more] mkVarid [v] = first toLower (map escape v) mkVarid [m,v] = first toUpper m++"."++first toLower (map escape v) diff --git a/src/Text/XML/HaXml/Schema/Parse.hs b/src/Text/XML/HaXml/Schema/Parse.hs --- a/src/Text/XML/HaXml/Schema/Parse.hs +++ b/src/Text/XML/HaXml/Schema/Parse.hs @@ -292,7 +292,7 @@ simpleType :: (String->String->QName) -> XsdParser SimpleType simpleType q = do e <- xsdElement "simpleType" - n <- optional (attribute (N "name") name e) + n <- optional (attribute (N "name") string e) f <- optional (attribute (N "final") final e) a <- interiorWith (xsdTag "annotation") annotation e commit $ interiorWith (not . xsdTag "annotation") (simpleItem n f a) e @@ -652,7 +652,3 @@ `onFail` do cs <- many next return (N (a++cs)) - --- | Parse an attribute value that should be a simple Name. -name :: TextParser Name -name = word diff --git a/src/Text/XML/HaXml/Schema/PrettyHaskell.hs b/src/Text/XML/HaXml/Schema/PrettyHaskell.hs --- a/src/Text/XML/HaXml/Schema/PrettyHaskell.hs +++ b/src/Text/XML/HaXml/Schema/PrettyHaskell.hs @@ -39,12 +39,14 @@ -- (but without escapes in comment text yet) ppComment :: CommentPosition -> Comment -> Doc ppComment _ Nothing = empty -ppComment pos (Just s) = - text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c - $$ - vcat (map (\x-> text "-- " <+> text x) cs) +ppComment pos (Just s) = case ps of + (c:cs) -> + text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c + $$ + vcat (map (\x-> text "-- " <+> text x) cs) + [] -> empty where - (c:cs) = lines (paragraph 60 s) + ps = lines (paragraph 60 s) -- | Generate aligned haddock-style docs for choices (where each choice -- has its own documentation, but haddock cannot place it directly next diff --git a/src/Text/XML/HaXml/Schema/TypeConversion.hs b/src/Text/XML/HaXml/Schema/TypeConversion.hs --- a/src/Text/XML/HaXml/Schema/TypeConversion.hs +++ b/src/Text/XML/HaXml/Schema/TypeConversion.hs @@ -27,7 +27,9 @@ ++ map renameLocals (schema_items s) } where hoist :: ElementDecl -> [SchemaItem] - hoist e = flip concatMap (findE e) $ + hoist e = + let only_children = filter (not . (==) e) $ findE e + in flip concatMap only_children $ \e@ElementDecl{elem_nameOrRef=Left (NT{ theName=n {-, theType=Nothing-}})}-> localType n (elem_content e) @@ -398,6 +400,10 @@ (elem_modifier e)}) es) (comment (group_annotation g)) + Right (QN _ ref) -> case Map.lookup (N ref) (env_group env) of + Nothing -> error $ "bad group reference " + ++printableName (N ref) + Just g' -> group g'{ group_occurs=group_occurs g } Right ref -> case Map.lookup ref (env_group env) of -- Nothing -> error $ "bad group reference " -- ++printableName ref