HaXml 1.24.1 → 1.25
raw patch · 6 files changed
+183/−63 lines, 6 filesdep ~polyparse
Dependency ranges changed: polyparse
Files
- HaXml.cabal +12/−12
- src/Text/XML/HaXml/Schema/NameConversion.hs +29/−10
- src/Text/XML/HaXml/Schema/Parse.hs +18/−2
- src/Text/XML/HaXml/Schema/PrettyHaskell.hs +1/−1
- src/Text/XML/HaXml/Schema/TypeConversion.hs +112/−36
- src/tools/FpMLToHaskell.hs +11/−2
HaXml.cabal view
@@ -1,10 +1,10 @@ name: HaXml-version: 1.24.1+version: 1.25 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace <Malcolm.Wallace@me.com> maintainer: author-homepage: http://www.cs.york.ac.uk/fp/HaXml/+homepage: http://projects.haskell.org/HaXml/ category: Text, XML synopsis: Utilities for manipulating XML documents description:@@ -66,7 +66,7 @@ exposed-modules: Text.XML.HaXml.Schema.Schema hs-source-dirs: src- build-depends: polyparse >= 1.9, filepath+ build-depends: polyparse >= 1.10, filepath if flag(splitBase) build-depends: base >= 3 && < 6, pretty, random, containers else@@ -76,63 +76,63 @@ else build-depends: base < 2 || >= 3, bytestring extensions: CPP, ExistentialQuantification- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" nhc98-options: -K10M Executable Canonicalise GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: Canonicalise.hs Executable CanonicaliseLazy GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: CanonicaliseLazy.hs Executable Xtract GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: Xtract.hs Executable Validate GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: Validate.hs Executable MkOneOf GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: MkOneOf.hs Executable DtdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: DtdToHaskell.hs Executable XsdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: XsdToHaskell.hs Executable FpMLToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DVERSION="\"1.24.1\""+ cpp-options: -DVERSION="\"1.25\"" Main-Is: FpMLToHaskell.hs build-depends: directory
src/Text/XML/HaXml/Schema/NameConversion.hs view
@@ -59,12 +59,19 @@ local = (:[]) . Prelude.last . hierarchy + mkConid [] = "Empty" mkConid [c] | map toLower c == "string" = "Xsd.XsdString"- | otherwise = first toUpper c+ | otherwise = first toUpper $ map escape c mkConid [m,c] | map toLower c == "string" = "Xsd.XsdString"- | otherwise = first toUpper m++"."++first toUpper c- mkVarid [v] = first toLower v- mkVarid [m,v] = first toUpper m++"."++first toLower v+ | map toLower c == "date" = "Xsd.Date"+ | map toLower c == "double" = "Xsd.Double"+ | map toLower c == "integer" = "Xsd.Integer"+ | map toLower c == "boolean" = "Xsd.Boolean"+ | map toLower c == "decimal" = "Xsd.Decimal"+ | otherwise = first toUpper m++"."++first toUpper (map escape c)+ mkConid more = mkConid [concat more]+ mkVarid [v] = first toLower (map escape v)+ mkVarid [m,v] = first toUpper m++"."++first toLower (map escape v) first f (x:xs) | not (isAlpha x) = f 'v': x: xs@@ -72,6 +79,13 @@ last f [x] = [ f x ] last f (x:xs) = x: last f xs +-- | Character escapes to create a valid Haskell identifier.+escape :: Char -> Char+escape x | x==' ' = '_'+ | x=='_' = '_'+ | isAlphaNum x = x+ | otherwise = '\''+ -- cleanUp = map (\c-> if not (isAlphaNum c) then '_' else c) -- | Ensure that a string does not match a Haskell keyword.@@ -152,9 +166,10 @@ let t = mkVarId . local $ qnt f = mkVarId . local $ qnf in HName $ if t==f then f- else if t `isPrefixOf` f- then t ++"_"++ mkVarId (drop (length t) f)- else mkVarId (shorten (mkConId t)) ++"_"++ f+ else mkVarId (shorten (mkConId t)) ++"_"+++ if t `isPrefixOf` f+ then mkVarId (drop (length t) f)+ else f } where hierarchy (N n) = wordsBy (==':') n@@ -163,14 +178,14 @@ local = Prelude.last . hierarchy mkVarId ("id") = "ID"- mkVarId (v:vs) = toLower v: vs- mkConId (v:vs) = toUpper v: vs+ mkVarId (v:vs) = toLower v: map escape vs+ mkConId (v:vs) = toUpper v: map escape vs shorten t | length t <= 12 = t | length t < 35 = concatMap shortenWord (splitWords t) | otherwise = map toLower (head t: filter isUpper (tail t)) splitWords "" = []- splitWords (u:s) = let (w,rest) = span (not . isUpper) s+ splitWords (u:s) = let (w,rest) = span (not . (\c->isUpper c || c=='_')) s in (u:w) : splitWords rest shortenWord "Request" = "Req" -- some special cases@@ -195,6 +210,10 @@ shortenWord "Property" = "Prop" shortenWord "Affirmation" = "Affirmation" shortenWord "Affirmed" = "Affirmed"+ shortenWord "KnockIn" = "KnockIn" -- avoid shortening+ shortenWord "Knockin" = "Knockin"+ shortenWord "KnockOut" = "KnockOut"+ shortenWord "Knockout" = "Knockout" shortenWord w | length w < 8 = w -- then the general rule | otherwise = case splitAt 5 w of (pref,c:suf) | isVowel c -> pref
src/Text/XML/HaXml/Schema/Parse.hs view
@@ -253,6 +253,19 @@ , ("xsd:attributeGroup", fmap AttributeGroup (attributeGroup qual)) , ("xsd:group", fmap SchemaGroup (group_ qual)) -- , ("xsd:notation", notation)+-- sigh+ , ("xs:include", include)+ , ("xs:import", import_)+ , ("xs:redefine", (redefine qual))+ , ("xs:annotation", fmap Annotation definiteAnnotation)+ --+ , ("xs:simpleType", fmap Simple (simpleType qual))+ , ("xs:complexType", fmap Complex (complexType qual))+ , ("xs:element", fmap SchemaElement (elementDecl qual))+ , ("xs:attribute", fmap SchemaAttribute (attributeDecl qual))+ , ("xs:attributeGroup", fmap AttributeGroup (attributeGroup qual))+ , ("xs:group", fmap SchemaGroup (group_ qual))+ -- , ("xs:notation", notation) ] -- | Parse an <xsd:include>.@@ -321,7 +334,7 @@ `apply` (return Restriction1 `apply` particle q) restrictType a b = return (RestrictType a b) `apply` (optional (simpleType q))- `apply` many aFacet+ `apply` many1 aFacet aFacet :: XsdParser Facet aFacet = foldr onFail (fail "Could not recognise simpleType Facet")@@ -598,7 +611,10 @@ -- | Text parser for an arbitrary string consisting of possibly multiple tokens. string :: TextParser String-string = fmap concat $ many word+string = fmap concat $ many (space `onFail` word)++space :: TextParser String+space = many1 $ satisfy isSpace -- | Parse a textual boolean, i.e. "true", "false", "0", or "1" bool :: TextParser Bool
src/Text/XML/HaXml/Schema/PrettyHaskell.hs view
@@ -343,7 +343,7 @@ where item (i,c) = (ppUnqConId nx t <> text "_" <> ppConId nx i) $$ ppComment After c- parseItem (i,_) = text "do isWord \"" <> ppXName i <> text "\"; return"+ parseItem (i,_) = text "do literal \"" <> ppXName i <> text "\"; return" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i) enumText (i,_) = text "simpleTypeText" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i)
src/Text/XML/HaXml/Schema/TypeConversion.hs view
@@ -17,6 +17,78 @@ import Data.Maybe (fromMaybe,fromJust,isNothing,isJust) import Data.Monoid +-- | Transform a Schema by lifting all locally-defined anonymous types to+-- the top-level, naming them, and planting a referend at their original+-- location.+typeLift :: Schema -> Schema+typeLift s = s{ schema_items =+ concat [ hoist e | SchemaElement e <- schema_items s ]+ ++ map renameLocals (schema_items s) }+ where+ hoist :: ElementDecl -> [SchemaItem]+ hoist e = flip concatMap (findE e) $+ \e@ElementDecl{elem_nameOrRef=Left (NT{ theName=n+ {-, theType=Nothing-}})}->+ localType n (elem_content e)++ findE :: ElementDecl -> [ElementDecl]+ findE e = ( case elem_nameOrRef e of+ Left (NT{theType=Nothing}) -> (e:)+ Left (NT{theType=Just t}) -> case elem_content e of+ Just (Right+ (ComplexType+ {complex_name=Just t'}))+ {-| t==t'-}+ -> (e:)+ _ -> id+ _ -> id+ ) $+ ( case elem_content e of+ Nothing -> []+ Just (Left _) -> []+ Just (Right c) ->+ case complex_content c of+ v@SimpleContent{ci_stuff=Left (Restriction1 p)} -> particle p+ v@SimpleContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p+ v@ComplexContent{ci_stuff=Left (Restriction1 p)} -> particle p+ v@ComplexContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p+ v@ThisType{ci_thistype=PA p _ _} -> particle p+ )+ particle Nothing = []+ particle (Just (Left cos)) = choiceOrSeq cos+ particle (Just (Right g)) = maybe [] choiceOrSeq $ group_stuff g+ choiceOrSeq (XSD.All _ es) = concatMap findE es+ choiceOrSeq (XSD.Choice _ _ es) = concatMap etc es+ choiceOrSeq (XSD.Sequence _ _ es) = concatMap etc es+ etc (HasElement e) = findE e+ etc (HasGroup g) = maybe [] choiceOrSeq $ group_stuff g+ etc (HasCS cos) = choiceOrSeq cos+ etc (HasAny _) = []++ localType n Nothing = []+ localType n (Just (Left s)) = [Simple (renameSimple n s)]+ localType n (Just (Right c)) = [Complex c{ complex_name = Just n }]++ renameSimple n s@Primitive{} = s+ renameSimple n s@Restricted{} = s{ simple_name = Just n }+ renameSimple n s@ListOf{} = s{ simple_name = Just n }+ renameSimple n s@UnionOf{} = s{ simple_name = Just n }+++-- * For now, rather than walk the tree, giving typenames to nodes that were+-- previously locally-typed, we will instead assume in the pretty-printer+-- that it can always replace a missing typename with the element name, and+-- have it resolve to something sensible.+ renameLocals :: SchemaItem -> SchemaItem+ renameLocals s = s+-- renameLocals (SchemaElement e)+-- | Left (NT{theName=n,theType=Nothing}) <- elem_nameOrRef e+-- = SchemaElement e{ elem_nameOrRef = Left (NT{theName=n+-- ,theType=Just n})+-- }+-- -- still gotta do the recursive search + rename++ -- | Given an environment of schema type mappings, and a schema module, -- create a bunch of Decls that describe the types in a more -- Haskell-friendly way.@@ -186,17 +258,17 @@ ({-elems-}es) ({-attrs-}as) (comment (elem_annotation ed))- , ElementOfType- Element{ elem_name = xname (theName n)- , elem_type = checkXName s (N $ theName n)- , elem_modifier =- Haskell.Range (elem_occurs ed)- , elem_byRef = False- , elem_locals = []- , elem_substs = Nothing- , elem_comment =- (comment (elem_annotation ed))- }+ , ElementOfType $ elementDecl ed+ -- Element{ elem_name = xname (theName n)+ -- , elem_type = checkXName s (N $ theName n)+ -- , elem_modifier =+ -- Haskell.Range (elem_occurs ed)+ -- , elem_byRef = False+ -- , elem_locals = []+ -- , elem_substs = Nothing+ -- , elem_comment =+ -- (comment (elem_annotation ed))+ -- } ] Just t | elem_abstract ed -> let nm = N $ theName n@@ -213,20 +285,15 @@ $ Map.lookup nm (env_substGrp env)) (comment (elem_annotation ed)) Just t | otherwise ->- singleton $ ElementOfType $- Element{ elem_name = xname $ theName n- , elem_type = checkXName s t- , elem_modifier= Haskell.Range (elem_occurs ed)- , elem_byRef = False- , elem_locals = []- , elem_substs = Nothing- -- , elem_substs = if elem_abstract ed- -- then fmap (map XName) $- -- Map.lookup (N $ theName n)- -- (env_substGrp env)- -- else Nothing- , elem_comment = comment (elem_annotation ed)- }+ singleton $ ElementOfType $ elementDecl ed+ -- Element{ elem_name = xname $ theName n+ -- , elem_type = checkXName s t+ -- , elem_modifier= Haskell.Range (elem_occurs ed)+ -- , elem_byRef = False+ -- , elem_locals = []+ -- , elem_substs = Nothing+ -- , elem_comment = comment (elem_annotation ed)+ -- } Right ref -> case Map.lookup ref (env_element env) of Nothing -> error $ "<topElementDecl> unknown element reference " ++printableName ref@@ -234,15 +301,21 @@ elementDecl :: XSD.ElementDecl -> Haskell.Element elementDecl ed = case elem_nameOrRef ed of- Left n -> Element ({-name-}xname $ theName n)- ({-type-}maybe (localTypeExp ed)- XName- (theType n))- ({-modifier-}Haskell.Range $ elem_occurs ed)- False -- by reference- [] -- internal Decl- Nothing -- substitution group- (comment (elem_annotation ed))+ Left n -> Element { elem_name = xname $ theName n+ , elem_type = maybe (localTypeExp ed)+ (checkXName s)+ (theType n)+ , elem_modifier = Haskell.Range $ elem_occurs ed+ , elem_byRef = False -- by reference+ , elem_locals = [] -- internal Decl+ , elem_substs = Nothing -- substitution group+ -- , elem_substs = if elem_abstract ed+ -- then fmap (map XName) $+ -- Map.lookup (N $ theName n)+ -- (env_substGrp env)+ -- else Nothing+ , elem_comment = comment $ elem_annotation ed+ } Right ref -> case Map.lookup ref (env_element env) of Just e' -> (elementDecl e') { elem_modifier =@@ -273,7 +346,8 @@ simple_restriction st) Left st@ListOf{} -> xname "SomethingListy" Left st@UnionOf{} -> xname "SomethingUnionLike"- Right c@ComplexType{} -> xname $ fromMaybe "unknown"+ Right c@ComplexType{} -> maybe (localTypeExp ed{elem_content=Nothing})+ xname $ complex_name c | otherwise = case elem_nameOrRef ed of@@ -284,7 +358,9 @@ attributeDecl ad = case attr_nameOrRef ad of Left n -> singleton $ Attribute (xname $ theName n)- (maybe (maybe (error "XSD.attributeDecl->")+ (maybe (maybe (xname $ "String")+ -- guess at an attribute typename?+ --(error "XSD.attributeDecl->") nameOfSimple (attr_simpleType ad)) XName
src/tools/FpMLToHaskell.hs view
@@ -12,6 +12,7 @@ import System.Environment import System.IO import Control.Monad+import Control.Exception as E import System.Directory import Data.List import Data.Maybe (fromMaybe,catMaybes)@@ -75,7 +76,7 @@ (dir,files) <- argDirsToFiles deps <- flip mapM files (\ (inf,outf)-> do hPutStrLn stdout $ "Reading "++inf- thiscontent <- readFile (dir++"/"++inf)+ thiscontent <- readFileUTF8 (dir++"/"++inf) let d@Document{} = resolveAllNames qualify . either (error . ("not XML:\n"++)) id . xmlParse' inf@@ -147,7 +148,9 @@ flip mapM_ environs (\ (inf,(env,outf,v))-> do o <- openFile outf WriteMode hb <- openFile (bootf outf) WriteMode- let decls = XsdToH.convert env v+ hSetEncoding o utf8+ hSetEncoding hb utf8+ let decls = XsdToH.convert env (XsdToH.typeLift v) haskell = Haskell.mkModule inf v decls doc = ppModule fpmlNameConverter haskell docboot = HsBoot.ppModule fpmlNameConverter haskell@@ -214,3 +217,9 @@ xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"}) "schema" +-- | UTF8-clean readFile; avoids handle-leaks.+readFileUTF8 :: FilePath -> IO String+readFileUTF8 file = do+ h <- openFile file ReadMode+ (do hSetEncoding h utf8+ hGetContents h) `E.onException` (hClose h)