summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--HaXml.cabal24
-rw-r--r--src/Text/XML/HaXml/Schema/NameConversion.hs39
-rw-r--r--src/Text/XML/HaXml/Schema/Parse.hs20
-rw-r--r--src/Text/XML/HaXml/Schema/PrettyHaskell.hs2
-rw-r--r--src/Text/XML/HaXml/Schema/TypeConversion.hs148
-rw-r--r--src/tools/FpMLToHaskell.hs13
6 files changed, 183 insertions, 63 deletions
diff --git a/HaXml.cabal b/HaXml.cabal
index 1b25c6e..3c11aee 100644
--- 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 <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 @@ library
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 @@ library
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
index 39950ea..b096093 100644
--- a/src/Text/XML/HaXml/Schema/NameConversion.hs
+++ b/src/Text/XML/HaXml/Schema/NameConversion.hs
@@ -59,12 +59,19 @@ simpleNameConverter = NameConverter
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 @@ simpleNameConverter = NameConverter
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 @@ fpmlNameConverter = simpleNameConverter
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 @@ fpmlNameConverter = simpleNameConverter
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 @@ fpmlNameConverter = simpleNameConverter
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
index d3acfc2..d9e0336 100644
--- a/src/Text/XML/HaXml/Schema/Parse.hs
+++ b/src/Text/XML/HaXml/Schema/Parse.hs
@@ -253,6 +253,19 @@ schemaItem qual = oneOf'
, ("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 @@ simpleType q = do
`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 @@ uri = string
-- | 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
index 11996e8..2dbfcba 100644
--- a/src/Text/XML/HaXml/Schema/PrettyHaskell.hs
+++ b/src/Text/XML/HaXml/Schema/PrettyHaskell.hs
@@ -343,7 +343,7 @@ ppHighLevelDecl nx (EnumSimpleType t is comm) =
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
index 62d2efd..5cbd8ff 100644
--- a/src/Text/XML/HaXml/Schema/TypeConversion.hs
+++ b/src/Text/XML/HaXml/Schema/TypeConversion.hs
@@ -17,6 +17,78 @@ import Data.List (foldl')
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 @@ convert env s = concatMap item (schema_items s)
({-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 @@ convert env s = concatMap item (schema_items s)
$ 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 @@ convert env s = concatMap item (schema_items s)
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 @@ convert env s = concatMap item (schema_items s)
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 @@ convert env s = concatMap item (schema_items s)
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
index e1fd4b7..328645c 100644
--- a/src/tools/FpMLToHaskell.hs
+++ b/src/tools/FpMLToHaskell.hs
@@ -12,6 +12,7 @@ import System.Exit
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 @@ main = do
(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 @@ main = do
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 :: QName
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)