diff --git a/HaXml.cabal b/HaXml.cabal --- a/HaXml.cabal +++ b/HaXml.cabal @@ -1,10 +1,10 @@ name: HaXml -version: 1.24.1 +version: 1.25 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace 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 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 @@ -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 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 @@ -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 . @@ -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 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 @@ -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) 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 @@ -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 $ " 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 diff --git a/src/tools/FpMLToHaskell.hs b/src/tools/FpMLToHaskell.hs --- a/src/tools/FpMLToHaskell.hs +++ b/src/tools/FpMLToHaskell.hs @@ -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)