summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMalcolmWallace <>2017-06-21 07:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-21 07:34:00 (GMT)
commitd4288905a3c348fdf08cd0da0ca394cc293a33a9 (patch)
tree19ae29478bd3dfd8fc2d0622e52ae0852e7ad5ce
parent7f033dad9176d14cd3e488af15f5be6c826d5751 (diff)
version 1.25.41.25.4
-rw-r--r--HaXml.cabal24
-rw-r--r--src/Text/XML/HaXml.hs5
-rw-r--r--src/Text/XML/HaXml/Lex.hs4
-rw-r--r--src/Text/XML/HaXml/Schema/TypeConversion.hs69
-rw-r--r--src/Text/XML/HaXml/Version.hs6
-rw-r--r--src/Text/XML/HaXml/Wrappers.hs5
-rw-r--r--src/tools/XsdToHaskell.hs2
7 files changed, 74 insertions, 41 deletions
diff --git a/HaXml.cabal b/HaXml.cabal
index c8b1875..2d37740 100644
--- a/HaXml.cabal
+++ b/HaXml.cabal
@@ -1,5 +1,5 @@
name: HaXml
-version: 1.25.3
+version: 1.25.4
license: LGPL
license-file: COPYRIGHT
author: Malcolm Wallace <Malcolm.Wallace@me.com>
@@ -55,6 +55,7 @@ library
Text.XML.HaXml.Util,
Text.XML.HaXml.Validate,
Text.XML.HaXml.Verbatim,
+ Text.XML.HaXml.Version
Text.XML.HaXml.Wrappers,
Text.XML.HaXml.XmlContent,
Text.XML.HaXml.XmlContent.Parser,
@@ -76,14 +77,12 @@ library
else
build-depends: base < 2 || >= 3, bytestring
extensions: CPP, ExistentialQuantification
- cpp-options: -DVERSION="\"1.25.3\""
nhc98-options: -K10M
Executable Canonicalise
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: Canonicalise.hs
build-depends: base, HaXml, pretty
@@ -91,54 +90,47 @@ Executable CanonicaliseLazy
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: CanonicaliseLazy.hs
build-depends: base, HaXml, pretty
-
+
Executable Xtract
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: Xtract.hs
build-depends: base, HaXml, pretty
-
+
Executable Validate
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: Validate.hs
build-depends: base, HaXml
-
+
Executable MkOneOf
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: MkOneOf.hs
build-depends: base, HaXml
-
+
Executable DtdToHaskell
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: DtdToHaskell.hs
build-depends: base, HaXml, pretty
-
+
Executable XsdToHaskell
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: XsdToHaskell.hs
build-depends: base, HaXml, pretty, polyparse, directory
-
+
Executable FpMLToHaskell
GHC-Options: -Wall
Extensions: CPP
Hs-Source-Dirs: src/tools
- cpp-options: -DVERSION="\"1.25.3\""
Main-Is: FpMLToHaskell.hs
build-depends: base, HaXml, pretty, polyparse, directory
diff --git a/src/Text/XML/HaXml.hs b/src/Text/XML/HaXml.hs
index d106240..c0dbfe3 100644
--- a/src/Text/XML/HaXml.hs
+++ b/src/Text/XML/HaXml.hs
@@ -28,10 +28,7 @@ import Text.XML.HaXml.Validate (validate)
import Text.XML.HaXml.Wrappers (fix2Args,processXmlWith)
import Text.XML.HaXml.Verbatim
import Text.XML.HaXml.Escape
+import Text.XML.HaXml.Version
import Text.PrettyPrint.HughesPJ (render)
--- | The version of the library.
-version :: String
-version = VERSION
- -- expect cpp to fill in value
diff --git a/src/Text/XML/HaXml/Lex.hs b/src/Text/XML/HaXml/Lex.hs
index 3796920..2b801b6 100644
--- a/src/Text/XML/HaXml/Lex.hs
+++ b/src/Text/XML/HaXml/Lex.hs
@@ -244,9 +244,11 @@ xmlAny w p s@('<':ss)
| "!" `prefixes` ss = emit TokSpecialOpen p:
skip 2 p s (xmlSpecial (InTag "<!...>":w))
| "/" `prefixes` ss = emit TokEndOpen p:
- skip 2 p s (xmlTag (InTag "</...>":tail w))
+ skip 2 p s (xmlTag (InTag "</...>":tale w))
| otherwise = emit TokAnyOpen p:
skip 1 p s (xmlTag (InTag "<...>":NotInTag:w))
+ where tale [] = [NotInTag] -- cope with non-well-formed input
+ tale xs = tail xs
xmlAny (_:_:w) p s@('/':ss)
| ">" `prefixes` ss = emit TokEndClose p: skip 2 p s (xmlAny w)
xmlAny w p ('&':ss) = emit TokAmp p: textUntil ";" TokSemi "" p
diff --git a/src/Text/XML/HaXml/Schema/TypeConversion.hs b/src/Text/XML/HaXml/Schema/TypeConversion.hs
index 36d001f..b46222f 100644
--- a/src/Text/XML/HaXml/Schema/TypeConversion.hs
+++ b/src/Text/XML/HaXml/Schema/TypeConversion.hs
@@ -112,7 +112,7 @@ convert env s = concatMap item (schema_items s)
simple (Primitive prim) = []
simple s@(Restricted a n f r)
| (Just enums) <- isEnumeration s
- = [EnumSimpleType
+ = [EnumSimpleType
(maybe (error "missing Name") xname n)
enums (comment a) ]
| otherwise = [RestrictSimpleType
@@ -126,7 +126,7 @@ convert env s = concatMap item (schema_items s)
-- (comment a)]
simple s@(UnionOf a n f u m)
| (Just enums) <- isEnumeration s
- = [EnumSimpleType
+ = [EnumSimpleType
(maybe (error "missing Name") xname n)
enums (comment a) ]
| otherwise = [UnionSimpleTypes
@@ -262,7 +262,7 @@ convert env s = concatMap item (schema_items s)
-- Element{ elem_name = xname (theName n)
-- , elem_type = checkXName s (N $ theName n)
-- , elem_modifier =
- -- Haskell.Range (elem_occurs ed)
+ -- occursToModifier (elem_occurs ed)
-- , elem_byRef = False
-- , elem_locals = []
-- , elem_substs = Nothing
@@ -288,16 +288,17 @@ convert env s = concatMap item (schema_items s)
singleton $ ElementOfType $ elementDecl ed
-- Element{ elem_name = xname $ theName n
-- , elem_type = checkXName s t
- -- , elem_modifier= Haskell.Range (elem_occurs ed)
+ -- , elem_modifier=
+ -- occursToModifier (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
- Just e' -> topElementDecl e'
+ Nothing -> error $ "<topElementDecl> unknown element reference "
+ ++printableName ref
+ Just e' -> topElementDecl e'
elementDecl :: XSD.ElementDecl -> Haskell.Element
elementDecl ed = case elem_nameOrRef ed of
@@ -305,7 +306,7 @@ convert env s = concatMap item (schema_items s)
, elem_type = maybe (localTypeExp ed)
(checkXName s)
(theType n)
- , elem_modifier = Haskell.Range $ elem_occurs ed
+ , elem_modifier = occursToModifier $ elem_occurs ed
, elem_byRef = False -- by reference
, elem_locals = [] -- internal Decl
, elem_substs = Nothing -- substitution group
@@ -319,19 +320,19 @@ convert env s = concatMap item (schema_items s)
Right ref -> case Map.lookup ref (env_element env) of
Just e' -> (elementDecl e')
{ elem_modifier =
- Haskell.Range (elem_occurs ed)
+ occursToModifier (elem_occurs ed)
, elem_byRef = True }
Nothing -> -- possible ref is imported qualified?
case Map.lookup (N $ localName ref)
(env_element env) of
Just e' -> (elementDecl e')
{ elem_modifier =
- Haskell.Range (elem_occurs ed)
+ occursToModifier (elem_occurs ed)
, elem_byRef = True }
Nothing -> Element ({-name-}XName ref)
-- best guess at type
({-type-}XName ref)
- (Haskell.Range (elem_occurs ed))
+ (occursToModifier (elem_occurs ed))
True [] Nothing Nothing
localTypeExp :: XSD.ElementDecl -> XName
@@ -386,7 +387,12 @@ convert env s = concatMap item (schema_items s)
Left n -> let ({-highs,-}es) = choiceOrSeq (fromMaybe (error "XSD.group")
(group_stuff g))
in {-highs ++-} singleton $
- Haskell.Group (xname n) es
+ Haskell.Group (xname n)
+ (map (\e->e{elem_modifier=
+ combineOccursModifier
+ (group_occurs g)
+ (elem_modifier e)})
+ es)
(comment (group_annotation g))
Right ref -> case Map.lookup ref (env_group env) of
-- Nothing -> error $ "bad group reference "
@@ -394,7 +400,7 @@ convert env s = concatMap item (schema_items s)
Nothing -> singleton $
Haskell.Group (xname ("unknown-group-"++printableName ref)) []
(comment (group_annotation g))
- Just g' -> group g'
+ Just g' -> group g'{ group_occurs=group_occurs g }
particleAttrs :: ParticleAttrs -> ([Haskell.Element],[Haskell.Attribute])
particleAttrs (PA part attrs _) = -- ignoring AnyAttr for now
@@ -410,7 +416,7 @@ convert env s = concatMap item (schema_items s)
choiceOrSeq (XSD.All ann eds) = error "not yet implemented: XSD.All"
choiceOrSeq (XSD.Choice ann o ees) = [ OneOf (anyToEnd
(map elementEtc ees))
- (Haskell.Range o)
+ (occursToModifier o)
(comment ann) ]
choiceOrSeq (XSD.Sequence ann _ ees) = concatMap elementEtc ees
@@ -422,7 +428,7 @@ convert env s = concatMap item (schema_items s)
any :: XSD.Any -> [Haskell.Element]
any a@XSD.Any{} = [Haskell.AnyElem
- { elem_modifier = Haskell.Range (any_occurs a)
+ { elem_modifier = occursToModifier (any_occurs a)
, elem_comment = comment (any_annotation a) }]
-- If an ANY element is part of a choice, ensure it is the last part.
@@ -479,8 +485,10 @@ nameOfSimple (UnionOf _ (Just n) _ _ _) = xname n -- return to this
nameOfSimple s = xname "String" -- anonymous simple
mkRestrict :: XSD.Restriction -> [Haskell.Restrict]
-mkRestrict (RestrictSim1 ann base r1) =
- error "Not yet implemented: Restriction1 on simpletype"
+mkRestrict (RestrictSim1 ann base r1) = []
+-- = error "Not yet implemented: Restriction1 on simpletype"
+-- ^ This branch is not strictly correct. There ought to be some
+-- restrictions.
mkRestrict (RestrictType _ _ _ facets) =
(let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets
, f `elem` [OrderedBoundsMinIncl
@@ -530,6 +538,33 @@ consolidate (Occurs min max) (UnorderedMinLength,_,n) =
consolidate (Occurs min max) (UnorderedMaxLength,_,n) =
Occurs min (Just (read n))
+instance Monoid Occurs where
+ mempty = Occurs Nothing Nothing
+ (Occurs Nothing Nothing) `mappend` o = o
+ (Occurs (Just z) Nothing) `mappend` (Occurs min max)
+ = Occurs (Just $ maybe z (*z) min) max
+ (Occurs Nothing (Just x)) `mappend` (Occurs min max)
+ = Occurs min (Just $ maybe x (*x) max)
+ (Occurs (Just z) (Just x)) `mappend` (Occurs min max)
+ = Occurs (Just $ maybe z (*z) min)
+ (Just $ maybe x (*x) max)
+
+-- | Push another Occurs value inside an existing Modifier.
+combineOccursModifier :: Occurs -> Modifier -> Modifier
+combineOccursModifier o Haskell.Single = occursToModifier $ mappend o
+ $ Occurs (Just 1) (Just 1)
+combineOccursModifier o Haskell.Optional = occursToModifier $ mappend o
+ $ Occurs (Just 0) (Just 1)
+combineOccursModifier o (Haskell.Range o') = occursToModifier $ mappend o o'
+
+-- | Convert an occurs range to a Haskell-style type modifier (Maybe, List, Id)
+occursToModifier :: Occurs -> Modifier
+occursToModifier (Occurs Nothing Nothing) = Haskell.Single
+occursToModifier (Occurs (Just 0) Nothing) = Haskell.Optional
+occursToModifier (Occurs (Just 0) (Just 1)) = Haskell.Optional
+occursToModifier (Occurs (Just 1) (Just 1)) = Haskell.Single
+occursToModifier o = Haskell.Range o
+
-- | Find the supertype (if it exists) of a given type name.
supertypeOf :: Environment -> QName -> Maybe QName
diff --git a/src/Text/XML/HaXml/Version.hs b/src/Text/XML/HaXml/Version.hs
new file mode 100644
index 0000000..09371fa
--- /dev/null
+++ b/src/Text/XML/HaXml/Version.hs
@@ -0,0 +1,6 @@
+module Text.XML.HaXml.Version
+ ( version
+ ) where
+
+version :: String
+version = "1.25.4"
diff --git a/src/Text/XML/HaXml/Wrappers.hs b/src/Text/XML/HaXml/Wrappers.hs
index 7340b78..0d7977c 100644
--- a/src/Text/XML/HaXml/Wrappers.hs
+++ b/src/Text/XML/HaXml/Wrappers.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
-#define dummy -- just to ensure that cpp gets called on this file
+#define dummy -- just to ensure that cpp gets called on this file
module Text.XML.HaXml.Wrappers
( fix2Args
, processXmlWith
@@ -20,6 +20,7 @@ import Text.XML.HaXml.Posn (Posn,posInNewCxt)
import Text.XML.HaXml.Parse (xmlParse)
import Text.XML.HaXml.Html.Parse (htmlParse)
import Text.XML.HaXml.Pretty as PP(document)
+import Text.XML.HaXml.Version
import Text.PrettyPrint.HughesPJ (render)
@@ -31,7 +32,7 @@ fix2Args :: IO (String,String)
fix2Args = do
args <- getArgs
when ("--version" `elem` args) $ do
- putStrLn $ "part of HaXml-"++ VERSION
+ putStrLn $ "part of HaXml-" ++ version
exitWith ExitSuccess
when ("--help" `elem` args) $ do
putStrLn $ "See http://projects.haskell.org/HaXml"
diff --git a/src/tools/XsdToHaskell.hs b/src/tools/XsdToHaskell.hs
index b174ffb..64581e8 100644
--- a/src/tools/XsdToHaskell.hs
+++ b/src/tools/XsdToHaskell.hs
@@ -71,7 +71,7 @@ main =
let decls = convert (mkEnvironment inf v emptyEnv) v
haskl = Haskell.mkModule inf v decls
doc = ppModule simpleNameConverter haskl
- hPutStrLn stdout $ render doc
+ hPutStrLn o $ render doc
(Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"
hPutStrLn stdout $ "\n-----------------\n"
hPutStrLn stdout $ show v