HaXml 1.22.5 → 1.23
raw patch · 19 files changed
+1289/−260 lines, 19 filesdep +directorydep ~basenew-component:exe:FpMLToHaskell
Dependencies added: directory
Dependency ranges changed: base
Files
- COPYRIGHT +2/−1
- HaXml.cabal +18/−9
- src/Text/XML/HaXml/DtdToHaskell/Instance.hs +5/−5
- src/Text/XML/HaXml/OneOfN.hs +418/−61
- src/Text/XML/HaXml/Schema/Environment.hs +21/−1
- src/Text/XML/HaXml/Schema/HaskellTypeModel.hs +42/−26
- src/Text/XML/HaXml/Schema/Parse.hs +1/−1
- src/Text/XML/HaXml/Schema/PrettyHaskell.hs +351/−119
- src/Text/XML/HaXml/Schema/PrimitiveTypes.hs +80/−19
- src/Text/XML/HaXml/Schema/Schema.hs +60/−4
- src/Text/XML/HaXml/Schema/TypeConversion.hs +26/−4
- src/Text/XML/HaXml/Schema/XSDTypeModel.hs +9/−0
- src/Text/XML/HaXml/Types.hs +7/−1
- src/Text/XML/HaXml/Validate.hs +11/−3
- src/Text/XML/HaXml/Verbatim.hs +3/−1
- src/Text/XML/HaXml/XmlContent/Parser.hs +3/−1
- src/tools/DtdToHaskell.hs +1/−0
- src/tools/FpMLToHaskell.hs +216/−0
- src/tools/MkOneOf.hs +15/−4
COPYRIGHT view
@@ -1,5 +1,6 @@ The HaXml library and tools were written by and are copyright to- (c) copyright 1998-2011 Malcolm Wallace and Colin Runciman+ (c) copyright 1998-1999 Malcolm Wallace and Colin Runciman+ (c) copyright 2000-2012 Malcolm Wallace The HaXml library is licensed under the terms of the GNU Lesser General Public Licence (LGPL), which can be found in the file called
HaXml.cabal view
@@ -1,5 +1,5 @@ name: HaXml-version: 1.22.5+version: 1.23 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace <Malcolm.Wallace@me.com>@@ -75,54 +75,63 @@ else build-depends: base < 2 || >= 3, bytestring extensions: CPP, ExistentialQuantification- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 nhc98-options: -K10M Executable Canonicalise GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Canonicalise.hs Executable CanonicaliseLazy GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: CanonicaliseLazy.hs Executable Xtract GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Xtract.hs Executable Validate GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Validate.hs Executable MkOneOf GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: MkOneOf.hs Executable DtdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: DtdToHaskell.hs Executable XsdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src- cpp-options: -DMAJOR=1 -DMINOR=22+ cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: XsdToHaskell.hs++Executable FpMLToHaskell+ GHC-Options: -Wall+ Extensions: CPP+ Hs-Source-Dirs: src/tools, src+ cpp-options: -DMAJOR=1 -DMINOR=23+ Main-Is: FpMLToHaskell.hs+ build-depends: directory+
src/Text/XML/HaXml/DtdToHaskell/Instance.hs view
@@ -23,7 +23,7 @@ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( text "toContents" <+> topatval <+> text "=" $$- nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""+ nest 4 (text "[CElem (Elem (N \"" <> ppXName n <> text "\")" <+> toattr <+> text "[]) ()]") $$ text "parseContents = do" $$@@ -48,7 +48,7 @@ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$- nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""+ nest 4 (text "[CElem (Elem (N \"" <> ppXName n <> text "\")" <+> toattr <+> parens (mkToElem sts vs) <> text ") ()]") $$@@ -131,7 +131,7 @@ -- enumeration of attribute values mkInstance (EnumDef n es) = text "instance XmlAttrType" <+> ppHName n <+> text "where" $$- nest 4 ( text "fromAttrToTyp n (n',v)" $$+ nest 4 ( text "fromAttrToTyp n (N n',v)" $$ nest 4 (text "| n==n' = translate (attr2str v)" $$ text "| otherwise = Nothing") $$ nest 2 (text "where" <+> mkTranslate es)@@ -289,7 +289,7 @@ mkToAttr :: Name -> Doc mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+>- text "Just (n, str2attr" <+> doubleQuotes (ppXName n) <> text ")"+ text "Just (N n, str2attr" <+> doubleQuotes (ppXName n) <> text ")" mkFrFld :: Name -> (Name,StructType) -> Doc mkFrFld tag (n,st) =@@ -392,6 +392,6 @@ let vs = nameSupply sts in text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "="- $$ nest 4 (text "[CElem (Elem \"" <> ppXName tag <> text "\""<+> attrexp+ $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName tag <> text "\")"<+> attrexp <+> parens (mkToElem sts vs) <+> text ") ()]")
src/Text/XML/HaXml/OneOfN.hs view
@@ -2,6 +2,35 @@ import Text.XML.HaXml.XmlContent +-- | Somewhat of a nonsense - a choice of a single item. But sometimes it+-- occurs in auto-generated code.+data OneOf1 a+ = OneOf1 a+ deriving (Eq,Show)++instance (HTypeable a)+ => HTypeable (OneOf1 a)+ where toHType _ = Defined "OneOf1" [] []+ -- toHType m = Defined "OneOf1" [a] []+ -- where a = toHType $ (\ (OneOf1 a)->a) $ m++instance (XmlContent a)+ => XmlContent (OneOf1 a)+ where+ parseContents =+ (choice OneOf1+ $ fail "OneOf1")+ toContents (OneOf1 x) = toContents x++foldOneOf1 :: (a->z) -> + OneOf1 a+ -> z+foldOneOf1 a (OneOf1 z) = a z++----++-- | Equivalent to the Either type, but using the regular naming+-- scheme of this module. data OneOf2 a b = OneOf2 a | TwoOf2 b deriving (Eq,Show)@@ -13,7 +42,6 @@ -- where a = toHType $ (\ (OneOf2 a)->a) $ m -- b = toHType $ (\ (TwoOf2 b)->b) $ m - instance (XmlContent a,XmlContent b) => XmlContent (OneOf2 a b) where@@ -23,6 +51,12 @@ toContents (OneOf2 x) = toContents x toContents (TwoOf2 x) = toContents x +foldOneOf2 :: (a->z) -> (b->z) -> + OneOf2 a b+ -> z+foldOneOf2 a b (OneOf2 z) = a z+foldOneOf2 a b (TwoOf2 z) = b z+ ---- data OneOf3 a b c = OneOf3 a | TwoOf3 b | ThreeOf3 c@@ -42,6 +76,13 @@ toContents (TwoOf3 x) = toContents x toContents (ThreeOf3 x) = toContents x +foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> + OneOf3 a b c+ -> z+foldOneOf3 a b c (OneOf3 z) = a z+foldOneOf3 a b c (TwoOf3 z) = b z+foldOneOf3 a b c (ThreeOf3 z) = c z+ ---- data OneOf4 a b c d = OneOf4 a | TwoOf4 b | ThreeOf4 c | FourOf4 d@@ -62,6 +103,14 @@ toContents (ThreeOf4 x) = toContents x toContents (FourOf4 x) = toContents x +foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> + OneOf4 a b c d+ -> z+foldOneOf4 a b c d (OneOf4 z) = a z+foldOneOf4 a b c d (TwoOf4 z) = b z+foldOneOf4 a b c d (ThreeOf4 z) = c z+foldOneOf4 a b c d (FourOf4 z) = d z+ ---- data OneOf5 a b c d e = OneOf5 a | TwoOf5 b | ThreeOf5 c | FourOf5 d | FiveOf5 e@@ -84,18 +133,27 @@ toContents (FourOf5 x) = toContents x toContents (FiveOf5 x) = toContents x +foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> + OneOf5 a b c d e+ -> z+foldOneOf5 a b c d e (OneOf5 z) = a z+foldOneOf5 a b c d e (TwoOf5 z) = b z+foldOneOf5 a b c d e (ThreeOf5 z) = c z+foldOneOf5 a b c d e (FourOf5 z) = d z+foldOneOf5 a b c d e (FiveOf5 z) = e z+ ---- data OneOf6 a b c d e f = OneOf6 a | TwoOf6 b | ThreeOf6 c | FourOf6 d | FiveOf6 e | SixOf6 f deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f)+ ,HTypeable f) => HTypeable (OneOf6 a b c d e f) where toHType _ = Defined "OneOf6" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f)+ ,XmlContent f) => XmlContent (OneOf6 a b c d e f) where parseContents =@@ -109,6 +167,16 @@ toContents (FiveOf6 x) = toContents x toContents (SixOf6 x) = toContents x +foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + OneOf6 a b c d e f+ -> z+foldOneOf6 a b c d e f (OneOf6 z) = a z+foldOneOf6 a b c d e f (TwoOf6 z) = b z+foldOneOf6 a b c d e f (ThreeOf6 z) = c z+foldOneOf6 a b c d e f (FourOf6 z) = d z+foldOneOf6 a b c d e f (FiveOf6 z) = e z+foldOneOf6 a b c d e f (SixOf6 z) = f z+ ---- data OneOf7 a b c d e f g = OneOf7 a | TwoOf7 b | ThreeOf7 c | FourOf7 d | FiveOf7 e | SixOf7 f@@ -116,12 +184,12 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g)+ ,HTypeable f,HTypeable g) => HTypeable (OneOf7 a b c d e f g) where toHType _ = Defined "OneOf7" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g)+ ,XmlContent f,XmlContent g) => XmlContent (OneOf7 a b c d e f g) where parseContents =@@ -136,6 +204,18 @@ toContents (SixOf7 x) = toContents x toContents (SevenOf7 x) = toContents x +foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> + OneOf7 a b c d e f g+ -> z+foldOneOf7 a b c d e f g (OneOf7 z) = a z+foldOneOf7 a b c d e f g (TwoOf7 z) = b z+foldOneOf7 a b c d e f g (ThreeOf7 z) = c z+foldOneOf7 a b c d e f g (FourOf7 z) = d z+foldOneOf7 a b c d e f g (FiveOf7 z) = e z+foldOneOf7 a b c d e f g (SixOf7 z) = f z+foldOneOf7 a b c d e f g (SevenOf7 z) = g z+ ---- data OneOf8 a b c d e f g h = OneOf8 a | TwoOf8 b | ThreeOf8 c | FourOf8 d | FiveOf8 e | SixOf8 f@@ -143,12 +223,12 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h)+ ,HTypeable f,HTypeable g,HTypeable h) => HTypeable (OneOf8 a b c d e f g h) where toHType _ = Defined "OneOf8" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h)+ ,XmlContent f,XmlContent g,XmlContent h) => XmlContent (OneOf8 a b c d e f g h) where parseContents =@@ -164,6 +244,19 @@ toContents (SevenOf8 x) = toContents x toContents (EightOf8 x) = toContents x +foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> + OneOf8 a b c d e f g h+ -> z+foldOneOf8 a b c d e f g h (OneOf8 z) = a z+foldOneOf8 a b c d e f g h (TwoOf8 z) = b z+foldOneOf8 a b c d e f g h (ThreeOf8 z) = c z+foldOneOf8 a b c d e f g h (FourOf8 z) = d z+foldOneOf8 a b c d e f g h (FiveOf8 z) = e z+foldOneOf8 a b c d e f g h (SixOf8 z) = f z+foldOneOf8 a b c d e f g h (SevenOf8 z) = g z+foldOneOf8 a b c d e f g h (EightOf8 z) = h z+ ---- data OneOf9 a b c d e f g h i = OneOf9 a | TwoOf9 b | ThreeOf9 c | FourOf9 d | FiveOf9 e | SixOf9 f@@ -171,12 +264,12 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i) => HTypeable (OneOf9 a b c d e f g h i) where toHType _ = Defined "OneOf9" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i) => XmlContent (OneOf9 a b c d e f g h i) where parseContents =@@ -194,6 +287,20 @@ toContents (EightOf9 x) = toContents x toContents (NineOf9 x) = toContents x +foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> + OneOf9 a b c d e f g h i+ -> z+foldOneOf9 a b c d e f g h i (OneOf9 z) = a z+foldOneOf9 a b c d e f g h i (TwoOf9 z) = b z+foldOneOf9 a b c d e f g h i (ThreeOf9 z) = c z+foldOneOf9 a b c d e f g h i (FourOf9 z) = d z+foldOneOf9 a b c d e f g h i (FiveOf9 z) = e z+foldOneOf9 a b c d e f g h i (SixOf9 z) = f z+foldOneOf9 a b c d e f g h i (SevenOf9 z) = g z+foldOneOf9 a b c d e f g h i (EightOf9 z) = h z+foldOneOf9 a b c d e f g h i (NineOf9 z) = i z+ ---- data OneOf10 a b c d e f g h i j = OneOf10 a | TwoOf10 b | ThreeOf10 c | FourOf10 d | FiveOf10 e@@ -201,12 +308,12 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j) => HTypeable (OneOf10 a b c d e f g h i j) where toHType _ = Defined "OneOf10" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j) => XmlContent (OneOf10 a b c d e f g h i j) where parseContents =@@ -225,6 +332,21 @@ toContents (NineOf10 x) = toContents x toContents (TenOf10 x) = toContents x +foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> + OneOf10 a b c d e f g h i j+ -> z+foldOneOf10 a b c d e f g h i j (OneOf10 z) = a z+foldOneOf10 a b c d e f g h i j (TwoOf10 z) = b z+foldOneOf10 a b c d e f g h i j (ThreeOf10 z) = c z+foldOneOf10 a b c d e f g h i j (FourOf10 z) = d z+foldOneOf10 a b c d e f g h i j (FiveOf10 z) = e z+foldOneOf10 a b c d e f g h i j (SixOf10 z) = f z+foldOneOf10 a b c d e f g h i j (SevenOf10 z) = g z+foldOneOf10 a b c d e f g h i j (EightOf10 z) = h z+foldOneOf10 a b c d e f g h i j (NineOf10 z) = i z+foldOneOf10 a b c d e f g h i j (TenOf10 z) = j z+ ---- data OneOf11 a b c d e f g h i j k = OneOf11 a | TwoOf11 b | ThreeOf11 c | FourOf11 d | FiveOf11 e@@ -233,14 +355,14 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k) => HTypeable (OneOf11 a b c d e f g h i j k) where toHType _ = Defined "OneOf11" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k) => XmlContent (OneOf11 a b c d e f g h i j k) where parseContents =@@ -261,6 +383,22 @@ toContents (TenOf11 x) = toContents x toContents (ElevenOf11 x) = toContents x +foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> + OneOf11 a b c d e f g h i j k+ -> z+foldOneOf11 a b c d e f g h i j k (OneOf11 z) = a z+foldOneOf11 a b c d e f g h i j k (TwoOf11 z) = b z+foldOneOf11 a b c d e f g h i j k (ThreeOf11 z) = c z+foldOneOf11 a b c d e f g h i j k (FourOf11 z) = d z+foldOneOf11 a b c d e f g h i j k (FiveOf11 z) = e z+foldOneOf11 a b c d e f g h i j k (SixOf11 z) = f z+foldOneOf11 a b c d e f g h i j k (SevenOf11 z) = g z+foldOneOf11 a b c d e f g h i j k (EightOf11 z) = h z+foldOneOf11 a b c d e f g h i j k (NineOf11 z) = i z+foldOneOf11 a b c d e f g h i j k (TenOf11 z) = j z+foldOneOf11 a b c d e f g h i j k (ElevenOf11 z) = k z+ ---- data OneOf12 a b c d e f g h i j k l = OneOf12 a | TwoOf12 b | ThreeOf12 c | FourOf12 d | FiveOf12 e@@ -269,14 +407,14 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l) => HTypeable (OneOf12 a b c d e f g h i j k l) where toHType _ = Defined "OneOf12" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l) => XmlContent (OneOf12 a b c d e f g h i j k l) where parseContents =@@ -298,6 +436,23 @@ toContents (ElevenOf12 x) = toContents x toContents (TwelveOf12 x) = toContents x +foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + OneOf12 a b c d e f g h i j k l+ -> z+foldOneOf12 a b c d e f g h i j k l (OneOf12 z) = a z+foldOneOf12 a b c d e f g h i j k l (TwoOf12 z) = b z+foldOneOf12 a b c d e f g h i j k l (ThreeOf12 z) = c z+foldOneOf12 a b c d e f g h i j k l (FourOf12 z) = d z+foldOneOf12 a b c d e f g h i j k l (FiveOf12 z) = e z+foldOneOf12 a b c d e f g h i j k l (SixOf12 z) = f z+foldOneOf12 a b c d e f g h i j k l (SevenOf12 z) = g z+foldOneOf12 a b c d e f g h i j k l (EightOf12 z) = h z+foldOneOf12 a b c d e f g h i j k l (NineOf12 z) = i z+foldOneOf12 a b c d e f g h i j k l (TenOf12 z) = j z+foldOneOf12 a b c d e f g h i j k l (ElevenOf12 z) = k z+foldOneOf12 a b c d e f g h i j k l (TwelveOf12 z) = l z+ ---- data OneOf13 a b c d e f g h i j k l m = OneOf13 a | TwoOf13 b | ThreeOf13 c | FourOf13 d | FiveOf13 e@@ -306,14 +461,14 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m) => HTypeable (OneOf13 a b c d e f g h i j k l m) where toHType _ = Defined "OneOf13" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m) => XmlContent (OneOf13 a b c d e f g h i j k l m) where parseContents =@@ -336,6 +491,25 @@ toContents (TwelveOf13 x) = toContents x toContents (ThirteenOf13 x) = toContents x +foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> + OneOf13 a b c d e f g h i j k l m+ -> z+foldOneOf13 a b c d e f g h i j k l m (OneOf13 z) = a z+foldOneOf13 a b c d e f g h i j k l m (TwoOf13 z) = b z+foldOneOf13 a b c d e f g h i j k l m (ThreeOf13 z) = c z+foldOneOf13 a b c d e f g h i j k l m (FourOf13 z) = d z+foldOneOf13 a b c d e f g h i j k l m (FiveOf13 z) = e z+foldOneOf13 a b c d e f g h i j k l m (SixOf13 z) = f z+foldOneOf13 a b c d e f g h i j k l m (SevenOf13 z) = g z+foldOneOf13 a b c d e f g h i j k l m (EightOf13 z) = h z+foldOneOf13 a b c d e f g h i j k l m (NineOf13 z) = i z+foldOneOf13 a b c d e f g h i j k l m (TenOf13 z) = j z+foldOneOf13 a b c d e f g h i j k l m (ElevenOf13 z) = k z+foldOneOf13 a b c d e f g h i j k l m (TwelveOf13 z) = l z+foldOneOf13 a b c d e f g h i j k l m (ThirteenOf13 z) = m z+ ---- data OneOf14 a b c d e f g h i j k l m n = OneOf14 a | TwoOf14 b | ThreeOf14 c | FourOf14 d | FiveOf14 e@@ -344,14 +518,14 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n) => HTypeable (OneOf14 a b c d e f g h i j k l m n) where toHType _ = Defined "OneOf14" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n) => XmlContent (OneOf14 a b c d e f g h i j k l m n) where parseContents =@@ -376,6 +550,26 @@ toContents (ThirteenOf14 x) = toContents x toContents (FourteenOf14 x) = toContents x +foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> + OneOf14 a b c d e f g h i j k l m n+ -> z+foldOneOf14 a b c d e f g h i j k l m n (OneOf14 z) = a z+foldOneOf14 a b c d e f g h i j k l m n (TwoOf14 z) = b z+foldOneOf14 a b c d e f g h i j k l m n (ThreeOf14 z) = c z+foldOneOf14 a b c d e f g h i j k l m n (FourOf14 z) = d z+foldOneOf14 a b c d e f g h i j k l m n (FiveOf14 z) = e z+foldOneOf14 a b c d e f g h i j k l m n (SixOf14 z) = f z+foldOneOf14 a b c d e f g h i j k l m n (SevenOf14 z) = g z+foldOneOf14 a b c d e f g h i j k l m n (EightOf14 z) = h z+foldOneOf14 a b c d e f g h i j k l m n (NineOf14 z) = i z+foldOneOf14 a b c d e f g h i j k l m n (TenOf14 z) = j z+foldOneOf14 a b c d e f g h i j k l m n (ElevenOf14 z) = k z+foldOneOf14 a b c d e f g h i j k l m n (TwelveOf14 z) = l z+foldOneOf14 a b c d e f g h i j k l m n (ThirteenOf14 z) = m z+foldOneOf14 a b c d e f g h i j k l m n (FourteenOf14 z) = n z+ ---- data OneOf15 a b c d e f g h i j k l m n o = OneOf15 a | TwoOf15 b | ThreeOf15 c | FourOf15 d | FiveOf15 e@@ -385,14 +579,14 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o) => HTypeable (OneOf15 a b c d e f g h i j k l m n o) where toHType _ = Defined "OneOf15" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o) => XmlContent (OneOf15 a b c d e f g h i j k l m n o) where parseContents =@@ -418,6 +612,27 @@ toContents (FourteenOf15 x) = toContents x toContents (FifteenOf15 x) = toContents x +foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> + OneOf15 a b c d e f g h i j k l m n o+ -> z+foldOneOf15 a b c d e f g h i j k l m n o (OneOf15 z) = a z+foldOneOf15 a b c d e f g h i j k l m n o (TwoOf15 z) = b z+foldOneOf15 a b c d e f g h i j k l m n o (ThreeOf15 z) = c z+foldOneOf15 a b c d e f g h i j k l m n o (FourOf15 z) = d z+foldOneOf15 a b c d e f g h i j k l m n o (FiveOf15 z) = e z+foldOneOf15 a b c d e f g h i j k l m n o (SixOf15 z) = f z+foldOneOf15 a b c d e f g h i j k l m n o (SevenOf15 z) = g z+foldOneOf15 a b c d e f g h i j k l m n o (EightOf15 z) = h z+foldOneOf15 a b c d e f g h i j k l m n o (NineOf15 z) = i z+foldOneOf15 a b c d e f g h i j k l m n o (TenOf15 z) = j z+foldOneOf15 a b c d e f g h i j k l m n o (ElevenOf15 z) = k z+foldOneOf15 a b c d e f g h i j k l m n o (TwelveOf15 z) = l z+foldOneOf15 a b c d e f g h i j k l m n o (ThirteenOf15 z) = m z+foldOneOf15 a b c d e f g h i j k l m n o (FourteenOf15 z) = n z+foldOneOf15 a b c d e f g h i j k l m n o (FifteenOf15 z) = o z+ ---- data OneOf16 a b c d e f g h i j k l m n o p = OneOf16 a | TwoOf16 b | ThreeOf16 c | FourOf16 d | FiveOf16 e@@ -427,16 +642,16 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o- ,HTypeable p)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o+ ,HTypeable p) => HTypeable (OneOf16 a b c d e f g h i j k l m n o p) where toHType _ = Defined "OneOf16" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o- ,XmlContent p)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o+ ,XmlContent p) => XmlContent (OneOf16 a b c d e f g h i j k l m n o p) where parseContents =@@ -463,6 +678,28 @@ toContents (FifteenOf16 x) = toContents x toContents (SixteenOf16 x) = toContents x +foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> (p->z) -> + OneOf16 a b c d e f g h i j k l m n o p+ -> z+foldOneOf16 a b c d e f g h i j k l m n o p (OneOf16 z) = a z+foldOneOf16 a b c d e f g h i j k l m n o p (TwoOf16 z) = b z+foldOneOf16 a b c d e f g h i j k l m n o p (ThreeOf16 z) = c z+foldOneOf16 a b c d e f g h i j k l m n o p (FourOf16 z) = d z+foldOneOf16 a b c d e f g h i j k l m n o p (FiveOf16 z) = e z+foldOneOf16 a b c d e f g h i j k l m n o p (SixOf16 z) = f z+foldOneOf16 a b c d e f g h i j k l m n o p (SevenOf16 z) = g z+foldOneOf16 a b c d e f g h i j k l m n o p (EightOf16 z) = h z+foldOneOf16 a b c d e f g h i j k l m n o p (NineOf16 z) = i z+foldOneOf16 a b c d e f g h i j k l m n o p (TenOf16 z) = j z+foldOneOf16 a b c d e f g h i j k l m n o p (ElevenOf16 z) = k z+foldOneOf16 a b c d e f g h i j k l m n o p (TwelveOf16 z) = l z+foldOneOf16 a b c d e f g h i j k l m n o p (ThirteenOf16 z) = m z+foldOneOf16 a b c d e f g h i j k l m n o p (FourteenOf16 z) = n z+foldOneOf16 a b c d e f g h i j k l m n o p (FifteenOf16 z) = o z+foldOneOf16 a b c d e f g h i j k l m n o p (SixteenOf16 z) = p z+ ---- data OneOf17 a b c d e f g h i j k l m n o p q = OneOf17 a | TwoOf17 b | ThreeOf17 c | FourOf17 d | FiveOf17 e@@ -472,16 +709,16 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o- ,HTypeable p,HTypeable q)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o+ ,HTypeable p,HTypeable q) => HTypeable (OneOf17 a b c d e f g h i j k l m n o p q) where toHType _ = Defined "OneOf17" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o- ,XmlContent p,XmlContent q)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o+ ,XmlContent p,XmlContent q) => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q) where parseContents =@@ -510,6 +747,29 @@ toContents (SixteenOf17 x) = toContents x toContents (SeventeenOf17 x) = toContents x +foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> + OneOf17 a b c d e f g h i j k l m n o p q+ -> z+foldOneOf17 a b c d e f g h i j k l m n o p q (OneOf17 z) = a z+foldOneOf17 a b c d e f g h i j k l m n o p q (TwoOf17 z) = b z+foldOneOf17 a b c d e f g h i j k l m n o p q (ThreeOf17 z) = c z+foldOneOf17 a b c d e f g h i j k l m n o p q (FourOf17 z) = d z+foldOneOf17 a b c d e f g h i j k l m n o p q (FiveOf17 z) = e z+foldOneOf17 a b c d e f g h i j k l m n o p q (SixOf17 z) = f z+foldOneOf17 a b c d e f g h i j k l m n o p q (SevenOf17 z) = g z+foldOneOf17 a b c d e f g h i j k l m n o p q (EightOf17 z) = h z+foldOneOf17 a b c d e f g h i j k l m n o p q (NineOf17 z) = i z+foldOneOf17 a b c d e f g h i j k l m n o p q (TenOf17 z) = j z+foldOneOf17 a b c d e f g h i j k l m n o p q (ElevenOf17 z) = k z+foldOneOf17 a b c d e f g h i j k l m n o p q (TwelveOf17 z) = l z+foldOneOf17 a b c d e f g h i j k l m n o p q (ThirteenOf17 z) = m z+foldOneOf17 a b c d e f g h i j k l m n o p q (FourteenOf17 z) = n z+foldOneOf17 a b c d e f g h i j k l m n o p q (FifteenOf17 z) = o z+foldOneOf17 a b c d e f g h i j k l m n o p q (SixteenOf17 z) = p z+foldOneOf17 a b c d e f g h i j k l m n o p q (SeventeenOf17 z) = q z+ ---- data OneOf18 a b c d e f g h i j k l m n o p q r = OneOf18 a | TwoOf18 b | ThreeOf18 c | FourOf18 d | FiveOf18 e@@ -519,16 +779,16 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o- ,HTypeable p,HTypeable q,HTypeable r)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o+ ,HTypeable p,HTypeable q,HTypeable r) => HTypeable (OneOf18 a b c d e f g h i j k l m n o p q r) where toHType _ = Defined "OneOf18" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o- ,XmlContent p,XmlContent q,XmlContent r)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o+ ,XmlContent p,XmlContent q,XmlContent r) => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r) where parseContents =@@ -558,6 +818,30 @@ toContents (SeventeenOf18 x) = toContents x toContents (EighteenOf18 x) = toContents x +foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> + OneOf18 a b c d e f g h i j k l m n o p q r+ -> z+foldOneOf18 a b c d e f g h i j k l m n o p q r (OneOf18 z) = a z+foldOneOf18 a b c d e f g h i j k l m n o p q r (TwoOf18 z) = b z+foldOneOf18 a b c d e f g h i j k l m n o p q r (ThreeOf18 z) = c z+foldOneOf18 a b c d e f g h i j k l m n o p q r (FourOf18 z) = d z+foldOneOf18 a b c d e f g h i j k l m n o p q r (FiveOf18 z) = e z+foldOneOf18 a b c d e f g h i j k l m n o p q r (SixOf18 z) = f z+foldOneOf18 a b c d e f g h i j k l m n o p q r (SevenOf18 z) = g z+foldOneOf18 a b c d e f g h i j k l m n o p q r (EightOf18 z) = h z+foldOneOf18 a b c d e f g h i j k l m n o p q r (NineOf18 z) = i z+foldOneOf18 a b c d e f g h i j k l m n o p q r (TenOf18 z) = j z+foldOneOf18 a b c d e f g h i j k l m n o p q r (ElevenOf18 z) = k z+foldOneOf18 a b c d e f g h i j k l m n o p q r (TwelveOf18 z) = l z+foldOneOf18 a b c d e f g h i j k l m n o p q r (ThirteenOf18 z) = m z+foldOneOf18 a b c d e f g h i j k l m n o p q r (FourteenOf18 z) = n z+foldOneOf18 a b c d e f g h i j k l m n o p q r (FifteenOf18 z) = o z+foldOneOf18 a b c d e f g h i j k l m n o p q r (SixteenOf18 z) = p z+foldOneOf18 a b c d e f g h i j k l m n o p q r (SeventeenOf18 z) = q z+foldOneOf18 a b c d e f g h i j k l m n o p q r (EighteenOf18 z) = r z+ ---- data OneOf19 a b c d e f g h i j k l m n o p q r s = OneOf19 a | TwoOf19 b | ThreeOf19 c | FourOf19 d | FiveOf19 e@@ -568,16 +852,16 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o- ,HTypeable p,HTypeable q,HTypeable r,HTypeable s)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o+ ,HTypeable p,HTypeable q,HTypeable r,HTypeable s) => HTypeable (OneOf19 a b c d e f g h i j k l m n o p q r s) where toHType _ = Defined "OneOf19" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o- ,XmlContent p,XmlContent q,XmlContent r,XmlContent s)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o+ ,XmlContent p,XmlContent q,XmlContent r,XmlContent s) => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s) where parseContents =@@ -608,6 +892,32 @@ toContents (EighteenOf19 x) = toContents x toContents (NineteenOf19 x) = toContents x +foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> + (s->z) -> + OneOf19 a b c d e f g h i j k l m n o p q r s+ -> z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (OneOf19 z) = a z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (TwoOf19 z) = b z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (ThreeOf19 z) = c z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (FourOf19 z) = d z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (FiveOf19 z) = e z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (SixOf19 z) = f z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (SevenOf19 z) = g z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (EightOf19 z) = h z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (NineOf19 z) = i z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (TenOf19 z) = j z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (ElevenOf19 z) = k z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (TwelveOf19 z) = l z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (ThirteenOf19 z) = m z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (FourteenOf19 z) = n z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (FifteenOf19 z) = o z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (SixteenOf19 z) = p z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (SeventeenOf19 z) = q z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (EighteenOf19 z) = r z+foldOneOf19 a b c d e f g h i j k l m n o p q r s (NineteenOf19 z) = s z+ ---- data OneOf20 a b c d e f g h i j k l m n o p q r s t = OneOf20 a | TwoOf20 b | ThreeOf20 c | FourOf20 d | FiveOf20 e@@ -618,16 +928,16 @@ deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e- ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j- ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o- ,HTypeable p,HTypeable q,HTypeable r,HTypeable s,HTypeable t)+ ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j+ ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o+ ,HTypeable p,HTypeable q,HTypeable r,HTypeable s,HTypeable t) => HTypeable (OneOf20 a b c d e f g h i j k l m n o p q r s t) where toHType _ = Defined "OneOf20" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e- ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j- ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o- ,XmlContent p,XmlContent q,XmlContent r,XmlContent s,XmlContent t)+ ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j+ ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o+ ,XmlContent p,XmlContent q,XmlContent r,XmlContent s,XmlContent t) => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t) where parseContents =@@ -659,5 +969,52 @@ toContents (EighteenOf20 x) = toContents x toContents (NineteenOf20 x) = toContents x toContents (TwentyOf20 x) = toContents x++foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> + (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> + (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> + (s->z) -> (t->z) -> + OneOf20 a b c d e f g h i j k l m n o p q r s t+ -> z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (OneOf20 z) = a z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (TwoOf20 z) = b z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (ThreeOf20 z) = c z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (FourOf20 z) = d z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (FiveOf20 z) = e z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (SixOf20 z) = f z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (SevenOf20 z) = g z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (EightOf20 z) = h z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (NineOf20 z) = i z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (TenOf20 z) = j z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (ElevenOf20 z) = k z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (TwelveOf20 z) = l z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (ThirteenOf20 z) = m z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (FourteenOf20 z) = n z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (FifteenOf20 z) = o z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (SixteenOf20 z) = p z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (SeventeenOf20 z) = q z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (EighteenOf20 z) = r z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (NineteenOf20 z) = s z+foldOneOf20 a b c d e f g h i j k l m n o p q r s+ t (TwentyOf20 z) = t z ----
src/Text/XML/HaXml/Schema/Environment.hs view
@@ -33,8 +33,20 @@ -- types, we need to be able to lift them out to the top-level, then -- refer to them by name only at the nested position(?) +-- When dealing with sub/supertype relationships, we often need to know all+-- of the subtypes of a supertype before some of the subtypes are actually+-- available in scope. The environment must therefore first be closed+-- over all modules: the resulting type mapping (env_type) should be _copied_+-- across to (env_allTypes) in a fresh initial environment, which latter is+-- then used to rebuild the local scope from scratch.+-- Likewise, the mappings from supertype->subtype (env_extendty) and for+-- substitution groups (env_substGrp) also need to be global.+ data Environment = Environment { env_type :: Map QName (Either SimpleType ComplexType)+ -- ^ type definitions in scope+ , env_allTypes :: Map QName (Either SimpleType ComplexType)+ -- ^ all type definitions, regardless of scope , env_element :: Map QName ElementDecl , env_attribute :: Map QName AttributeDecl , env_group :: Map QName Group@@ -48,12 +60,13 @@ -- | An empty environment of XSD type mappings. emptyEnv :: Environment emptyEnv = Environment Map.empty Map.empty Map.empty Map.empty Map.empty- Map.empty Map.empty Map.empty Map.empty+ Map.empty Map.empty Map.empty Map.empty Map.empty -- | Combine two environments (e.g. read from different interface files) combineEnv :: Environment -> Environment -> Environment combineEnv e1 e0 = Environment { env_type = Map.union (env_type e1) (env_type e0)+ , env_allTypes = Map.union (env_allTypes e1) (env_allTypes e0) , env_element = Map.union (env_element e1) (env_element e0) , env_attribute = Map.union (env_attribute e1) (env_attribute e0) , env_group = Map.union (env_group e1) (env_group e0)@@ -107,6 +120,13 @@ [(mkN n, fp)] (env_extendty env)}) (isExtn (complex_content c))+ $ (if complex_abstract c then \env->+ -- because an abstract type might have no concrete instantiations!+ env{env_extendty = Map.insertWith (++)+ (mkN n)+ []+ (env_extendty env)}+ else id) $ env{env_type=Map.insert (mkN n) (Right c) (env_type env) ,env_typeloc=Map.insert (mkN n) fp (env_typeloc env)} where isExtn x@SimpleContent{} = ci_stuff x
src/Text/XML/HaXml/Schema/HaskellTypeModel.hs view
@@ -11,7 +11,7 @@ import Data.List (partition) -- | Comments can be attached to most things, but not all of them will exist.-type Comment = Maybe String+type Comment = Maybe String -- | The whole Haskell module. data Module = Module@@ -22,26 +22,6 @@ , module_decls :: [Decl] -- the body of the module } -mkModule :: String -> Schema -> [Decl] -> Module-mkModule name schema decls =- Module { module_name = XName $ N name- , module_xsd_ns = xsdQualification- (schema_namespaces schema)- , module_re_exports = reexports- , module_import_only = imports- , module_decls = theRest- }- where (reexports,other) = partition xsdinclude decls- (imports, theRest) = partition xsdimport other- xsdinclude (XSDInclude _ _) = True- xsdinclude _ = False- xsdimport (XSDImport _ _ _) = True- xsdimport _ = False- xsdQualification nss = fmap (XName . N . nsPrefix) $- lookupBy ((==xsd).nsURI) nss- where xsd = "http://www.w3.org/2001/XMLSchema"-- -- | There are essentially simple types, and complex types, each of which -- can be either restricted or extended. There are four kinds of complex -- type: choices, sequences, named groups, or a simple element with content.@@ -78,6 +58,16 @@ -- data FwdC = FwdC -- because C is not yet in scope -- instance FwdDecl FwdC C -- later, at defn of C --+ -- In fact, it is better to move the declaration of type C+ -- here, rather than use a FwdDecl proxy. This will require+ -- some patching later where C was originally declared.+ -- data T = T_A A+ -- | T_B B+ -- | T_C C -- but C not yet declared+ -- | ...+ -- data C = ... -- because C is not yet in scope+ -- -- later, at true defn site of C, omit its decl.+ -- -- An earlier solution was -- class T a where parseT :: String -> XMLParser a -- instance T A@@ -85,7 +75,10 @@ -- instance T C -- but this is incorrect because the choice between A|B|C -- rests with the input doc, not with the caller of the parser.- | ElementsAttrsAbstract XName [(XName,Maybe XName)] Comment+ | ElementsAttrsAbstract {-typename-}XName+ {-subtypes-}[(XName,Maybe XName)]+ -- ^ [(type name, module where declared later)]+ Comment -- becomes function -- elementE :: Parser T@@ -128,10 +121,11 @@ -- or when T is itself abstract, extending an abstract type S -- class T a where parseT :: String -> XMLParser a -- instance (T a) => S a where parseS = parseT- | ExtendComplexTypeAbstract XName XName [(XName,Maybe XName)]- {-FwdDecl instnc req'd-}(Maybe XName)- {-grandsupertypes-}[XName]- Comment+ | ExtendComplexTypeAbstract XName XName+ {-subtypes-}[(XName,Maybe XName)]+ {-FwdDecl instnc req'd-}(Maybe XName)+ {-grandsupertypes-}[XName]+ Comment -- becomes an import and re-export | XSDInclude XName Comment@@ -161,6 +155,7 @@ deriving (Eq,Show) data Attribute = Attribute { attr_name :: XName , attr_type :: XName+ , attr_required:: Bool , attr_comment :: Comment } deriving (Eq,Show)@@ -176,4 +171,25 @@ | Enumeration [(String,Comment)] | StrLength Occurs Comment deriving (Eq,Show)+++-- | A helper for building the formal Module structure.+mkModule :: String -> Schema -> [Decl] -> Module+mkModule name schema decls =+ Module { module_name = XName $ N name+ , module_xsd_ns = xsdQualification+ (schema_namespaces schema)+ , module_re_exports = reexports+ , module_import_only = imports+ , module_decls = theRest+ }+ where (reexports,other) = partition xsdinclude decls+ (imports, theRest) = partition xsdimport other+ xsdinclude (XSDInclude _ _) = True+ xsdinclude _ = False+ xsdimport (XSDImport _ _ _) = True+ xsdimport _ = False+ xsdQualification nss = fmap (XName . N . nsPrefix) $+ lookupBy ((==xsd).nsURI) nss+ where xsd = "http://www.w3.org/2001/XMLSchema"
src/Text/XML/HaXml/Schema/Parse.hs view
@@ -633,7 +633,7 @@ qname :: (String->String->QName) -> TextParser QName qname q = do a <- word ( do ":" <- word- b <- word+ b <- many (satisfy (/=':')) return (q a b) `onFail` do cs <- many next
src/Text/XML/HaXml/Schema/PrettyHaskell.hs view
@@ -7,8 +7,6 @@ , ppModule , ppHighLevelDecl , ppHighLevelDecls- , ppModuleWithInstances- , ppHighLevelInstances , ppvList ) where @@ -19,7 +17,8 @@ import Text.PrettyPrint.HughesPJ as PP import Data.List (intersperse,notElem,inits)-import Data.Maybe (isJust,fromJust,catMaybes)+import Data.Maybe (isJust,fromJust,fromMaybe,catMaybes)+import Data.Char (toLower) -- | Vertically pretty-print a list of things, with open and close brackets, -- and separators.@@ -42,6 +41,35 @@ where (c:cs) = 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+-- to the appropriate component.+ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc+ppCommentForChoice pos outer nested =+ text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c+ $$ vcat (map (\x-> text "-- " <+> text x) cs)+ $$ vcat (map (\x-> text "-- " <+> text x) bullets)+ where+ (c:cs) = lines intro+ intro = maybe "Choice between:"+ (\s-> paragraph 60 s++"\n\nChoice between:")+ outer+ bullets = concatMap lines+ $ zipWith (\n seq-> case seq of+ [x]-> "\n("++show n++") "++paragraph 56 x+ _ -> "\n("++show n++") Sequence of:"+ ++ concatMap (\s->"\n\n * "+ ++paragraph 52 s)+ seq)+ [1..]+ $ map (map safeComment)+ $ nested+ safeComment Text = "mixed text"+ safeComment e@Element{} = fromMaybe (xname $ elem_name e) (elem_comment e)+ safeComment e@_ = fromMaybe ("unknown") (elem_comment e)+ xname (XName (N x)) = x+ xname (XName (QN ns x)) = nsPrefix ns++":"++x+ -- | Pretty-print a Haskell-style name. ppHName :: HName -> Doc ppHName (HName x) = text x@@ -68,8 +96,7 @@ -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc ppModule nx m =- text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,"- $$ text " ExistentialQuantification, FlexibleContexts #-}"+ text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}" $$ text "{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}" $$ text "module" <+> ppModId nx (module_name m) $$ nest 2 (text "( module" <+> ppModId nx (module_name m)@@ -81,61 +108,54 @@ $$ text " " $$ text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))" $$ text "import Text.XML.HaXml.Schema.Schema as Schema"- $$ (case module_xsd_ns m of- Nothing -> text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd"- Just ns -> text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"<+>ppConId nx ns)- $$ vcat (map (ppHighLevelDecl nx)- (module_re_exports m ++ module_import_only m))- $$ text " "- $$ ppHighLevelDecls nx (module_decls m)---- | Generate a supplementary module to contain instances, especially for--- types that needed to be forward-declared.-ppModuleWithInstances :: NameConverter -> Module -> Doc-ppModuleWithInstances nx m =- text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,"- $$ text " ExistentialQuantification, FlexibleContexts #-}"- $$ text "{-# OPTIONS_GHC -fno-warn-orphan-instances #-}"- $$ text "module" <+> ppModId nx (module_name m) <> text "Instances"- $$ nest 2 (text "( module" <+> ppModId nx (module_name m)- <> text "Instances"- $$ text ") where")- $$ text " "- $$ text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))"- $$ text "import Text.XML.HaXml.Schema.Schema as Schema"+ $$ text "import Text.XML.HaXml.OneOfN" $$ (case module_xsd_ns m of Nothing -> text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd" Just ns -> text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"<+>ppConId nx ns) $$ vcat (map (ppHighLevelDecl nx) (module_re_exports m ++ module_import_only m)) $$ text " "- $$ text "import" <+> ppModId nx (module_name m)- $$ text "-- More imports are required, extracted from FwdDecls"+ $$ text "-- Some hs-boot imports are required, for fwd-declaring types." $$ vcat (map ppFwdDecl $ concatMap imports $ module_decls m)+ $$ vcat (map ppFwdElem $ concatMap importElems $ module_decls m) $$ text " "- $$ vcat (intersperse (text " ")- (map (ppHighLevelInstances nx)- (filter hasInstances (module_decls m))))- where- hasInstances ElementsAttrsAbstract{} = True- hasInstances ElementAbstractOfType{} = True- hasInstances ExtendComplexType{} = True- hasInstances ExtendComplexTypeAbstract{} = True- hasInstances _ = False+ $$ ppHighLevelDecls nx (module_decls m) - imports (ElementsAttrsAbstract _ insts _) = insts- imports (ExtendComplexTypeAbstract _ _ insts _ _ _) = insts+ where+ imports (ElementsAttrsAbstract _ deps _) = deps+ imports (ExtendComplexTypeAbstract _ _ deps _ _ _) = deps imports _ = [] + importElems (ElementAbstractOfType _ _ deps _) = deps+ importElems _ = []+ ppFwdDecl (_, Nothing) = empty- ppFwdDecl (name,Just mod) = text "import" <+> ppModId nx mod- <+> text "-- for" <+> ppConId nx name+ ppFwdDecl (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod+ <+> text "(" <+> ppConId nx name <+> text ")" + ppFwdElem (_, Nothing) = empty+ ppFwdElem (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod+ <+> text "("+ <+> (text "element" <> ppUnqConId nx name)+ <> (text ", elementToXML" <> ppUnqConId nx name)+ <+> text ")"++ -- | Generate a fragmentary parser for an attribute. ppAttr :: Attribute -> Int -> Doc-ppAttr a n = (text "a"<>text (show n)) <+> text "<- getAttribute \""+ppAttr a n = (text "a"<>text (show n)) <+> text "<-"+ <+> (if attr_required a then empty+ else text "optional $")+ <+> text "getAttribute \"" <> ppXName (attr_name a) <> text "\" e pos"++-- | Generate a fragmentary toXML for an attribute.+toXmlAttr :: Attribute -> Doc+toXmlAttr a = (if attr_required a then id+ else (\d-> text "maybe []" <+> parens d))+ (text "toXMLAttribute \"" <> ppXName (attr_name a) <> text "\"")+ -- | Generate a fragmentary parser for an element. ppElem :: NameConverter -> Element -> Doc ppElem nx e@Element{}@@ -149,14 +169,18 @@ ppElem nx e@AnyElem{} = ppElemModifier (elem_modifier e) (text "parseAnyElement") ppElem nx e@Text{} = text "parseText"-ppElem nx e@OneOf{} = ppElemModifier (elem_modifier e)- (text "oneOf" <+> ppvList "[" "," "]"+ppElem nx e@OneOf{} = ppElemModifier (liftedElemModifier e)+ (text "oneOf'" <+> ppvList "[" "," "]" (ppOneOf n) (zip (elem_oneOf e) [1..n])) where n = length (elem_oneOf e)- ppOneOf n (e,i) = text "fmap" <+> text (ordinal i ++"Of"++show n)- <+> parens (ppSeqElem e)+ ppOneOf n (e,i) = text "(\"" <> hsep (map (ppElemTypeName nx id)+ . cleanChoices $ e)+ <> text "\","+ <+> text "fmap" <+> text (ordinal i ++"Of"++show n)+ <+> parens (ppSeqElem . cleanChoices $ e)+ <> text ")" ordinal i | i <= 20 = ordinals!!i | otherwise = "Choice" ++ show i ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight"@@ -167,6 +191,34 @@ ppSeqElem es = text ("return ("++replicate (length es-1) ','++")") <+> vcat (map (\e-> text "`apply`" <+> ppElem nx e) es) +-- | Generate a fragmentary toXML for an element. Fragment must still be+-- applied to an actual element value.+toXmlElem :: NameConverter -> Element -> Doc+toXmlElem nx e@Element{}+ | elem_byRef e = xmlElemModifier (elem_modifier e)+ (text "elementToXML"+ <> ppUnqConId nx (elem_name e))+ | otherwise = xmlElemModifier (elem_modifier e)+ (text "schemaTypeToXML \""+ <> ppXName (elem_name e)+ <> text "\"")+toXmlElem nx e@AnyElem{} = xmlElemModifier (elem_modifier e)+ (text "toXMLAnyElement")+toXmlElem nx e@Text{} = text "toXMLText"+toXmlElem nx e@OneOf{} = xmlElemModifier (liftedElemModifier e)+ (text "foldOneOf" <> text (show n)+ <+> ppvList "" "" "" xmlOneOf (elem_oneOf e))+ where+ n = length (elem_oneOf e)+ xmlOneOf e = parens (xmlSeqElem . cleanChoices $ e)+ xmlSeqElem [] = PP.empty+ xmlSeqElem [e] = toXmlElem nx e+ xmlSeqElem es = text "\\ (" <> hcat (intersperse (text ",") vars)+ <> text ") -> concat"+ <+> ppvList "[" "," "]" (\(e,v)-> toXmlElem nx e <+> v)+ (zip es vars)+ where vars = map (text.(:[])) . take (length es) $ ['a'..'z']+ -- | Convert multiple HaskellTypeModel Decls to Haskell source text. ppHighLevelDecls :: NameConverter -> [Decl] -> Doc ppHighLevelDecls nx hs = vcat (intersperse (text " ")@@ -193,6 +245,9 @@ $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") )+ $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "x) = " + $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]")+ ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "acceptingParser = fmap" <+> ppUnqConId nx t <+> text "acceptingParser"@@ -200,6 +255,8 @@ $$ text "-- XXX should enforce the restrictions somehow?" $$ text "-- The restrictions are:" $$ vcat (map ((text "-- " <+>) . ppRestrict) r))+ $$ nest 4 (text "simpleTypeText (" <> ppUnqConId nx t+ <+> text "x) = simpleTypeText x") where ppRestrict (RangeR occ comm) = text "(RangeR" <+> ppOccurs occ <> text ")"@@ -216,8 +273,10 @@ $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s <+> ppConId nx t_attrs+ <+> text "deriving (Eq,Show)" $$ text "data" <+> ppConId nx t_attrs <+> text "=" <+> ppConId nx t_attrs- $$ nest 4 (ppFields nx t_attrs [] as)+ $$ nest 4 (ppFields nx t_attrs [] as+ $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]"@@ -231,6 +290,16 @@ <+> attrsValue as) ) )+ $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t+ <+> text "bt at) ="+ $$ nest 4 (text "addXMLAttributes"+ <+> ppvList "[" "," "]"+ (\a-> toXmlAttr a <+> text "$"+ <+> ppFieldId nx t_attrs (attr_name a)+ <+> text "at")+ as+ $$ nest 4 (text "$ schemaTypeToXML s bt"))+ ) $$ text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ nest 4 (text "supertype (" <> ppUnqConId nx t <> text " s _) = s")@@ -264,73 +333,121 @@ $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") )+ $$ nest 4 (text "schemaTypeToXML s x = " + $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]")+ ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "acceptingParser ="- <+> ppvList "" "`onFail`" "" parseItem is)+ <+> ppvList "" "`onFail`" "" parseItem is+ $$ vcat (map enumText is)) where item (i,c) = (ppUnqConId nx t <> text "_" <> ppConId nx i) $$ ppComment After c parseItem (i,_) = text "do isWord \"" <> ppXName i <> text "\"; return" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i)+ enumText (i,_) = text "simpleTypeText"+ <+> (ppUnqConId nx t <> text "_" <> ppConId nx i)+ <+> text "= \"" <> ppXName i <> text "\"" ppHighLevelDecl nx (ElementsAttrs t es as comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t- $$ nest 8 (ppFields nx t (uniqueify es) as)+ $$ nest 8 (ppFields nx t (uniqueify es) as+ $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]"- $$ text "commit $ do"- $$ nest 2- (vcat (zipWith ppAttr as [0..])- $$ text "interior e $ return"+ -- $$ text "commit $ do"+ -- $$ nest 2+ $$ (vcat (zipWith ppAttr as [0..])+ $$ text "commit $ interior e $ return" <+> returnValue as $$ nest 4 (vcat (map ppApplyElem es)) ) ) )+ $$ nest 4 (text "schemaTypeToXML s x@"<> ppUnqConId nx t <> text "{} ="+ $$ nest 4 (text "toXMLElement s"+ <+> ppvList "[" "," "]"+ (\a-> toXmlAttr a <+> text "$"+ <+> ppFieldId nx t (attr_name a)+ <+> text "x")+ as+ $$ nest 4 (ppvList "[" "," "]"+ (\ (e,i)-> toXmlElem nx e+ <+> text "$"+ <+> ppFieldName nx t e i+ <+> text "x")+ (zip es [0..]))+ )+ ) where returnValue [] = ppUnqConId nx t returnValue as = parens (ppUnqConId nx t <+> hsep [text ("a"++show n) | n <- [0..length as-1]]) ppApplyElem e = text "`apply`" <+> ppElem nx e +ppHighLevelDecl nx (ElementsAttrsAbstract t [] comm) =+ ppComment Before comm+ $$ text "-- (There are no subtypes defined for this abstract type.)"+ $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t+ <+> text "deriving (Eq,Show)"+ $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"+ $$ nest 4 (text "parseSchemaType s = fail" <+> errmsg)+ $$ nest 4 (text "schemaTypeToXML s _ = toXMLElement s [] []")+ where+ errmsg = text "\"Parse failed when expecting an extension type of"+ <+> ppXName t <> text ":\\n No extension types are known.\"" ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t- $$ nest 8 (ppvList "=" "|" "" ppAbstrCons insts)- $$ text "-- instance SchemaType" <+> ppUnqConId nx t- <+> text "(declared in Instance module)"--- $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"--- $$ nest 4 (text "parseSchemaType s = do" --- $$ nest 4 (vcat (intersperse (text "`onFail`")--- (map ppParse insts)--- ++ [text "`onFail` fail" <+> errmsg])))- $$ text ""- $$ vcat (map ppFwdDecl $ filter (isJust . snd) insts)+ $$ nest 8 (ppvList "=" "|" "" ppAbstrCons insts+ $$ text "deriving (Eq,Show)")+-- $$ text "-- instance SchemaType" <+> ppUnqConId nx t+-- <+> text "(declared in Instance module)"+-- *** Declare instance here+ $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"+ $$ nest 4 (text "parseSchemaType s = do" + $$ nest 4 (vcat (intersperse (text "`onFail`")+ (map ppParse insts)+ ++ [text "`onFail` fail" <+> errmsg])))+ $$ nest 4 (vcat (map toXML insts))+-- $$ text ""+-- $$ vcat (map ppFwdDecl $ filter (isJust . snd) insts) where ppAbstrCons (name,Nothing) = con name <+> ppConId nx name- ppAbstrCons (name,Just mod) = text "forall q . (FwdDecl" <+>- fwd name <+> text "q," <+>- text "SchemaType q) =>" <+>- con name <+>- text "("<>fwd name<>text"->q)" <+> fwd name--- ppParse (name,Nothing) = text "(fmap" <+> con name <+>--- text "$ parseSchemaType s)"+ ppAbstrCons (name,Just mod) = con name <+> ppConId nx name+-- *** Declare FwdDecl type here (proxy for type declared in later module)+-- ppAbstrCons (name,Just mod) = text "forall q . (FwdDecl" <+>+-- fwd name <+> text "q," <+>+-- text "SchemaType q) =>" <+>+-- con name <+>+-- text "("<>fwd name<>text"->q)" <+> fwd name+ ppParse (name,Nothing) = text "(fmap" <+> con name <+>+ text "$ parseSchemaType s)"+ ppParse (name,Just _) = ppParse (name,Nothing) -- ppParse (name,Just _) = text "(return" <+> con name <+> -- text "`apply` (fmap const $ parseSchemaType s)" <+> -- text "`apply` return" <+> fwd name <> text ")"- ppFwdDecl (name,Just mod)- = text "-- | Proxy:" <+> ppConId nx name- <+> text "declared later in" <+> ppModId nx mod- $$ text "data" <+> fwd name <+> text "=" <+> fwd name--- errmsg = text "\"Parse failed when expecting an extension type of"--- <+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\"--- <> hcat (intersperse (text ",")--- (map (ppXName . fst) insts))--- <> text "\""- fwd name = ppFwdConId nx name+-- ppFwdDecl (name,Just mod)+-- = text "-- | Proxy:" <+> ppConId nx name+-- <+> text "declared later in" <+> ppModId nx mod+-- $$ text "data" <+> fwd name <+> text "=" <+> fwd name+ errmsg = text "\"Parse failed when expecting an extension type of"+ <+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\"+ <> hcat (intersperse (text ",")+ (map (ppXName . fst) insts))+ <> text "\""+-- fwd name = ppFwdConId nx name con name = ppJoinConId nx t name+ -- This is probably an unportable hack, but because an abstract type never+ -- has an element in its own name, we need to guess at the name of the+ -- possible subtype elements that could substitute for it.+ toXML (name,_) = text "schemaTypeToXML _s ("+ <> con name <+> text "x) = schemaTypeToXML \""+ <> ppXName (initLower name) <> text "\" x"+ initLower (XName (N (c:cs))) = XName $ N (toLower c:cs)+ initLower (XName (QN ns (c:cs))) = XName $ QN ns (toLower c:cs) ppHighLevelDecl nx (ElementOfType e@Element{}) = ppComment Before (elem_comment e)@@ -338,21 +455,66 @@ <+> text "XMLParser" <+> ppConId nx (elem_type e) $$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "=" <+> (text "parseSchemaType \"" <> ppXName (elem_name e) <> text "\"")+ $$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "::"+ <+> ppConId nx (elem_type e) <+> text "-> [Content ()]"+ $$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "="+ <+> (text "schemaTypeToXML \"" <> ppXName (elem_name e) <> text "\"") +ppHighLevelDecl nx e@(ElementAbstractOfType n t [] comm) =+ ppComment Before comm+ $$ text "-- (There are no elements in any substitution group for this element.)"+ $$ (text "element" <> ppUnqConId nx n) <+> text "::"+ <+> text "XMLParser" <+> ppConId nx t+ $$ (text "element" <> ppUnqConId nx n) <+> text "="+ <+> text "fail" <+> errmsg+ $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::"+ <+> ppConId nx t <+> text "-> [Content ()]"+ $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "="+ <+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"")+ where+ errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"+ <> ppXName n <> text ">,\\n\\\n\\ There are no substitutable elements.\"" ppHighLevelDecl nx e@(ElementAbstractOfType n t substgrp comm)- | any notInScope substgrp- = (text "-- element" <> ppUnqConId nx n) <+> text "::"- <+> text "XMLParser" <+> ppConId nx t- $$ text "-- declared in Instances module"- | otherwise = ppElementAbstractOfType nx e+-- | any notInScope substgrp+-- = (text "-- element" <> ppUnqConId nx n) <+> text "::"+-- <+> text "XMLParser" <+> ppConId nx t+-- $$ text "-- declared in Instances module"+ | otherwise = ppComment Before comm+ $$ (text "element" <> ppUnqConId nx n) <+> text "::"+ <+> text "XMLParser" <+> ppConId nx t+ $$ (text "element" <> ppUnqConId nx n) <+> text "="+ <+> vcat (intersperse (text "`onFail`") (map ppOne substgrp)+ ++ [text "`onFail` fail" <+> errmsg])+ $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::"+ <+> ppConId nx t <+> text "-> [Content ()]"+ $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "="+ <+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"")+ -- $$ vcat (map elementToXML substgrp)+-- | otherwise = ppElementAbstractOfType nx e where notInScope (_,Just _) = True notInScope (_,Nothing) = False+ ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c+ <+> (text "element" <> ppConId nx c)+ ppOne (c,Just _) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c+ <+> (text "element" <> ppConId nx c)+ <+> text "-- FIXME: element is forward-declared"+ errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"+ <> ppXName n <> text ">,\\n\\\n\\ namely one of:\\n\\\n\\<"+ <> hcat (intersperse (text ">, <")+ (map (ppXName . fst) substgrp))+ <> text ">\""+-- elementToXML (c,_) = (text "elementToXML" <> ppUnqConId nx n)+-- <+> text "(" <> ppJoinConId nx t c+-- <+> text " x) = elementToXML" <> ppUnqConId nx c+-- <+> text "x" + ppHighLevelDecl nx (Choice t es comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t- <+> nest 4 ( ppvList "=" "|" "" choices (zip es [1..]) )+ <+> nest 4 ( ppvList "=" "|" "" choices (zip es [1..])+ $$ text "deriving (Eq,Show)" ) where choices (e,n) = (ppUnqConId nx t <> text (show n)) <+> ppConId nx (elem_type e)@@ -373,7 +535,9 @@ ppComment Before comm $$ text "newtype" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s+ <+> text "deriving (Eq,Show)" $$ text "-- plus different (more restrictive) parser"+ $$ text "-- (parsing restrictions currently unimplemented)" $$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x")@@ -381,6 +545,8 @@ $$ nest 4 (text "parseSchemaType = fmap " <+> ppUnqConId nx t <+> text ". parseSchemaType") -- XXX should enforce the restriction.+ $$ nest 4 (text "schemaTypeToXML s (" <> ppUnqConId nx t <+> text "x)")+ <+> text "= schemaTypeToXML s x" {- ppHighLevelDecl nx (ExtendComplexType t s es as _ comm)@@ -389,6 +555,7 @@ $$ text "data" <+> ppConId nx t <+> text "=" <+> ppConId nx t <+> ppConId nx s <+> ppFields nx t es as+ <+> text "deriving (Eq,Show)" $$ text "instance Extension" <+> ppConId nx t <+> ppConId nx s <+> ppAuxConId nx t <+> text "where" $$ nest 4 (text "supertype (" <> ppConId nx t <> text " s e) = s"@@ -399,7 +566,7 @@ fwdReqd absSup grandsuper comm) = ppHighLevelDecl nx (ElementsAttrs t (oes++es) (oas++as) comm) $$ ppExtension nx t s fwdReqd absSup oes oas es as- $$ (if not (null grandsuper) -- && isJust fwdReqd+ $$ (if not (null grandsuper) -- && not (isJust fwdReqd) -- && isJust fwdReqd then ppSuperExtension nx s grandsuper (t,Nothing) else empty) @@ -407,10 +574,10 @@ fwdReqd grandsuper comm) = ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) $$ ppExtension nx t s fwdReqd True [] [] [] []- $$ if not (null grandsuper)- then vcat (map (ppSuperExtension nx t grandsuper) insts)- -- FIXME some instances are missing!- else empty+-- $$ if not (null grandsuper)+-- then vcat (map (ppSuperExtension nx t grandsuper) insts)+-- -- FIXME some instances are missing!+-- else empty ppHighLevelDecl nx (XSDInclude m comm) = ppComment After comm@@ -424,7 +591,7 @@ ppHighLevelDecl nx (XSDComment comm) = ppComment Before comm ---------------------------------------------------------------------------------+{------------------------------------------------------------------------------- -- | Instances that depend on FwdDecl'd types, need to be declared in a -- different module. So they have been separated out from ppHighLevelDecl.@@ -473,6 +640,7 @@ -- -- FIXME some instances are missing! -- else empty + ppElementAbstractOfType nx (ElementAbstractOfType n t substgrp comm) = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::"@@ -492,6 +660,8 @@ (map (ppXName . fst) substgrp)) <> text ">\"" +----------------------------------------------------------------------------- -}+ -------------------------------------------------------------------------------- -- | Generate an instance of the Extension class for a subtype/supertype pair.@@ -503,20 +673,21 @@ $$ (if abstractSuper then nest 4 (text "supertype v" <+> text "=" <+> ppJoinConId nx s t <+>- (if isJust fwdReqd- then text "(\\_-> v)" <+> ppFwdConId nx t- else text "v"))+ -- (if isJust fwdReqd+ -- then text "(\\_-> v)" <+> ppFwdConId nx t+ -- else text "v")+ text "v") else nest 4 (text "supertype (" <> ppType t (oes++es) (oas++as) <> text ") =" $$ nest 11 (ppType s oes oas) ))- $$ (if isJust fwdReqd then- -- text "data" <+> fwd t <+> text "=" <+> fwd t $$ -- already defined- text ""- $$ text "-- | Proxy" <+> fwd t <+> text "was declared earlier in"- <+> ppModId nx (fromJust fwdReqd)- $$ text "instance FwdDecl" <+> fwd t <+> ppConId nx t- else empty)+-- $$ (if isJust fwdReqd then+-- -- text "data" <+> fwd t <+> text "=" <+> fwd t $$ -- already defined+-- text ""+-- $$ text "-- | Proxy" <+> fwd t <+> text "was declared earlier in"+-- <+> ppModId nx (fromJust fwdReqd)+-- $$ text "instance FwdDecl" <+> fwd t <+> ppConId nx t+-- else empty) where fwd name = ppFwdConId nx name ppType t es as = ppUnqConId nx t@@ -540,10 +711,10 @@ <+> text "->" <+> ppConId nx super <> text ")")) -}-ppSuperExtension nx super (grandSuper:_) (t,Just mod) = -- fwddecl- -- FIXME: generate comment for all of the grandSupers.- text "-- instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper- $$ text "-- will be declared in module" <+> ppModId nx mod+ppSuperExtension nx super grandSupers (t,Just mod) = -- fwddecl+ text "-- Note that" <+> ppUnqConId nx t+ <+> text "will be declared later in module" <+> ppModId nx mod+ $$ ppSuperExtension nx super grandSupers (t,Nothing) ppSuperExtension nx super grandSupers (t,Nothing) = vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers)) where@@ -565,28 +736,36 @@ fields = map (ppFieldAttribute nx t) as ++ zipWith (ppFieldElement nx t) es [0..] --- | Generate a single named field from an element.+-- | Generate a single named field (including type sig) from an element. ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc-ppFieldElement nx t e@Element{} _ = ppFieldId nx t (elem_name e)- <+> text "::" <+> ppElemTypeName nx id e- $$ ppComment After (elem_comment e)-ppFieldElement nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i)- <+> text "::" <+> ppElemTypeName nx id e+ppFieldElement nx t e@Element{} i = ppFieldName nx t e i+ <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e)-ppFieldElement nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i)- <+> text "::" <+> ppElemTypeName nx id e+ppFieldElement nx t e@OneOf{} i = ppFieldName nx t e i+ <+> text "::" <+> ppElemTypeName nx id e+ $$ ppCommentForChoice After (elem_comment e)+ (elem_oneOf e)+ppFieldElement nx t e@AnyElem{} i = ppFieldName nx t e i+ <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e)-ppFieldElement nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i)- <+> text "::" <+> ppElemTypeName nx id e+ppFieldElement nx t e@Text{} i = ppFieldName nx t e i+ <+> text "::" <+> ppElemTypeName nx id e +-- | Generate a single named field (no type sig) from an element.+ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc+ppFieldName nx t e@Element{} _ = ppFieldId nx t (elem_name e)+ppFieldName nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i)+ppFieldName nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i)+ppFieldName nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i)+ -- | What is the name of the type for an Element (or choice of Elements)? ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e) ppElemTypeName nx brack e@OneOf{} = - brack $ ppTypeModifier (elem_modifier e) parens $+ brack $ ppTypeModifier (liftedElemModifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e)))- <+> hsep (map ppSeq (elem_oneOf e))+ <+> hsep (map (ppSeq . cleanChoices) (elem_oneOf e)) where ppSeq [] = text "()" ppSeq [e] = ppElemTypeName nx parens e@@ -602,6 +781,8 @@ -- | Generate a single named field from an attribute. ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc ppFieldAttribute nx t a = ppFieldId nx t (attr_name a) <+> text "::"+ <+> (if attr_required a then empty+ else text "Maybe") <+> ppConId nx (attr_type a) $$ ppComment After (attr_comment a) @@ -614,18 +795,69 @@ ppTypeModifier (Range (Occurs _ _)) _ d = text "[" <> d <> text "]" -- | Generate a parser for a list or Maybe value.+ppElemModifier :: Modifier -> Doc -> Doc ppElemModifier Single doc = doc ppElemModifier Optional doc = text "optional" <+> parens doc ppElemModifier (Range (Occurs Nothing Nothing)) doc = doc ppElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "optional" <+> parens doc+ppElemModifier (Range (Occurs (Just 0) (Just n))) doc+ | n==maxBound = text "many" <+> parens doc+ppElemModifier (Range (Occurs Nothing (Just n))) doc+ | n==maxBound = text "many1" <+> parens doc+ppElemModifier (Range (Occurs (Just 1) (Just n))) doc+ | n==maxBound = text "many1" <+> parens doc ppElemModifier (Range o) doc = text "between" <+> (parens (text (show o)) $$ parens doc) +-- | Generate a toXML for a list or Maybe value.+xmlElemModifier :: Modifier -> Doc -> Doc+xmlElemModifier Single doc = doc+xmlElemModifier Optional doc = text "maybe []" <+> parens doc+xmlElemModifier (Range (Occurs Nothing Nothing)) doc = doc+xmlElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "maybe []"+ <+> parens doc+xmlElemModifier (Range (Occurs _ _)) doc = text "concatMap" <+> parens doc++-- | Eliminate a Maybe type modifier, when it occurs directly inside a+-- choice construct (since a parsed Nothing would always be preferred over+-- a real value later in the choice). Likewise, empty lists must+-- be disallowed inside choice.+cleanChoices :: [Element] -> [Element]+cleanChoices [e@Element{}] = (:[]) $+ case elem_modifier e of+ Range (Occurs (Just 0) Nothing) -> e{elem_modifier=Single}+ Range (Occurs (Just 0) max)-> e{elem_modifier=Range (Occurs (Just 1) max)}+ _ -> e+cleanChoices es = es++-- | Sometimes, a choice without a type modifier contains element sequences,+-- all of which have the same modifier. In that case, it makes sense to lift+-- the modifier (typically Maybe) to the outer layer.+liftedElemModifier :: Element -> Modifier+liftedElemModifier e@OneOf{} =+ case elem_modifier e of+ Range (Occurs Nothing Nothing) -> newModifier+ Single -> newModifier+ m -> m+ where+ newModifier = if all (\x-> case x of+ Text -> True+ _ -> case elem_modifier x of+ Range (Occurs (Just 0) _) -> True+ Optional -> True+ _ -> False)+ (concat (elem_oneOf e))+ then Optional+ else Single+ -- | Split long lines of comment text into a paragraph with a maximum width. paragraph :: Int -> String -> String paragraph n s = go n (words s) where go i [] = []+ go i [x] | len<i = x+ | otherwise = "\n"++x+ where len = length x go i (x:xs) | len<i = x++" "++go (i-len-1) xs | otherwise = "\n"++x++" "++go (n-len-1) xs where len = length x
src/Text/XML/HaXml/Schema/PrimitiveTypes.hs view
@@ -66,6 +66,7 @@ -- as layered parsers. class SimpleType a where acceptingParser :: TextParser a+ simpleTypeText :: a -> String -- * Primitive types @@ -81,15 +82,20 @@ --data Float --data Double data Duration = Duration Bool Int Int Int Int Int Float deriving (Eq,Show)-data DateTime = DateTime deriving (Eq,Show) -- LocalTime ?-data Time = Time deriving (Eq,Show) -- TimeOfDay ?-data Date = Date deriving (Eq,Show) -- Day ?-data GYearMonth = GYearMonth deriving (Eq,Show)-data GYear = GYear deriving (Eq,Show)-data GMonthDay = GMonthDay deriving (Eq,Show)-data GDay = GDay deriving (Eq,Show)-data GMonth = GMonth deriving (Eq,Show) +-- * All of the following temporal types are incompletely specified for now.+-- They should probably be mapped to something appropriate from the time+-- package?++data DateTime = DateTime String deriving (Eq,Show) -- LocalTime ?+data Time = Time String deriving (Eq,Show) -- TimeOfDay ?+data Date = Date String deriving (Eq,Show) -- Day ?+data GYearMonth = GYearMonth String deriving (Eq,Show) -- ??+data GYear = GYear String deriving (Eq,Show) -- ??+data GMonthDay = GMonthDay String deriving (Eq,Show) -- ??+data GDay = GDay String deriving (Eq,Show) -- ??+data GMonth = GMonth String deriving (Eq,Show) -- ??+ isNext :: Char -> TextParser Char isNext c = do d <- next if c==d then return c else fail ("expected "++c:", got "++d:".")@@ -101,25 +107,35 @@ "0" -> return False; "1" -> return True _ -> fail ("Not a bool: "++w)+ simpleTypeText False = "false"+ simpleTypeText True = "true" instance SimpleType XsdString where- acceptingParser = fmap XsdString word+ acceptingParser = fmap XsdString (many next)+ simpleTypeText (XsdString s) = s instance SimpleType Base64Binary where acceptingParser = fmap Base64Binary (many (satisfy isAlphaNum `onFail` satisfy isSpace `onFail` satisfy (`elem`"+/=")))+ simpleTypeText (Base64Binary s) = s instance SimpleType HexBinary where acceptingParser = fmap HexBinary (many (satisfy Char.isHexDigit))+ simpleTypeText (HexBinary s) = s instance SimpleType AnyURI where acceptingParser = fmap AnyURI (many next) -- not very satisfactory+ simpleTypeText (AnyURI s) = s instance SimpleType NOTATION where acceptingParser = fmap NOTATION (many next) -- not very satisfactory+ simpleTypeText (NOTATION s) = s instance SimpleType Decimal where acceptingParser = fmap Decimal parse+ simpleTypeText (Decimal s) = show s -- XXX FIXME: showGFloat? instance SimpleType Float where- acceptingParser = parse+ acceptingParser = parse+ simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Double where- acceptingParser = parse+ acceptingParser = parse+ simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Duration where acceptingParser = return Duration `apply` (do isNext '-'; return False@@ -139,22 +155,42 @@ `onFail` return 0) `apply` ((parseFloat `discard` isNext 'S') `onFail` return 0)+ simpleTypeText (Duration pos y m d h n s) =+ (if pos then "" else "-")++show y++"Y"++show m++"M"++show d++"D"+ ++"T"++show h++"H"++show n++"M"++show s++"S"+ instance SimpleType DateTime where- acceptingParser = fail "not implemented: simpletype parser for DateTime"+ acceptingParser = fmap DateTime (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for DateTime"+ simpleTypeText (DateTime x) = x instance SimpleType Time where- acceptingParser = fail "not implemented: simpletype parser for Time"+ acceptingParser = fmap Time (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for Time"+ simpleTypeText (Time x) = x instance SimpleType Date where- acceptingParser = fail "not implemented: simpletype parser for Date"+ acceptingParser = fmap Date (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for Date"+ simpleTypeText (Date x) = x instance SimpleType GYearMonth where- acceptingParser = fail "not implemented: simpletype parser for GYearMonth"+ acceptingParser = fmap GYearMonth (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for GYearMonth"+ simpleTypeText (GYearMonth x) = x instance SimpleType GYear where- acceptingParser = fail "not implemented: simpletype parser for GYear"+ acceptingParser = fmap GYear (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for GYear"+ simpleTypeText (GYear x) = x instance SimpleType GMonthDay where- acceptingParser = fail "not implemented: simpletype parser for GMonthDay"+ acceptingParser = fmap GMonthDay (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for GMonthDay"+ simpleTypeText (GMonthDay x) = x instance SimpleType GDay where- acceptingParser = fail "not implemented: simpletype parser for GDay"+ acceptingParser = fmap GDay (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for GDay"+ simpleTypeText (GDay x) = x instance SimpleType GMonth where- acceptingParser = fail "not implemented: simpletype parser for GMonth"+ acceptingParser = fmap GMonth (many next)+ -- acceptingParser = fail "not implemented: simpletype parser for GMonth"+ simpleTypeText (GMonth x) = x -- * Derived builtin types @@ -173,28 +209,40 @@ instance SimpleType NormalizedString where acceptingParser = fmap Normalized (many next)+ simpleTypeText (Normalized x) = x instance SimpleType Token where acceptingParser = fmap Token (many next)+ simpleTypeText (Token x) = x instance SimpleType Language where acceptingParser = fmap Language (many next)+ simpleTypeText (Language x) = x instance SimpleType Name where acceptingParser = fmap Name (many next)+ simpleTypeText (Name x) = x instance SimpleType NCName where acceptingParser = fmap NCName (many next)+ simpleTypeText (NCName x) = x instance SimpleType ID where acceptingParser = fmap ID (many next)+ simpleTypeText (ID x) = x instance SimpleType IDREF where acceptingParser = fmap IDREF (many next)+ simpleTypeText (IDREF x) = x instance SimpleType IDREFS where acceptingParser = fmap IDREFS (many next)+ simpleTypeText (IDREFS x) = x instance SimpleType ENTITY where acceptingParser = fmap ENTITY (many next)+ simpleTypeText (ENTITY x) = x instance SimpleType ENTITIES where acceptingParser = fmap ENTITIES (many next)+ simpleTypeText (ENTITIES x) = x instance SimpleType NMTOKEN where acceptingParser = fmap NMTOKEN (many next)+ simpleTypeText (NMTOKEN x) = x instance SimpleType NMTOKENS where acceptingParser = fmap NMTOKENS (many next)+ simpleTypeText (NMTOKENS x) = x --data Integer newtype NonPositiveInteger = NonPos Integer deriving (Eq,Show)@@ -212,28 +260,41 @@ instance SimpleType Integer where acceptingParser = parse+ simpleTypeText = show instance SimpleType NonPositiveInteger where acceptingParser = fmap NonPos parse+ simpleTypeText (NonPos x) = show x instance SimpleType NegativeInteger where acceptingParser = fmap Negative parse+ simpleTypeText (Negative x) = show x instance SimpleType Long where acceptingParser = fmap (Long . fromInteger) parse+ simpleTypeText (Long x) = show x instance SimpleType Int where acceptingParser = parse+ simpleTypeText = show instance SimpleType Short where acceptingParser = fmap (Short . fromInteger) parse+ simpleTypeText (Short x) = show x instance SimpleType Byte where acceptingParser = fmap (Byte . fromInteger) parse+ simpleTypeText (Byte x) = show x instance SimpleType NonNegativeInteger where acceptingParser = fmap NonNeg parse+ simpleTypeText (NonNeg x) = show x instance SimpleType UnsignedLong where acceptingParser = fmap (ULong . fromInteger) parse+ simpleTypeText (ULong x) = show x instance SimpleType UnsignedInt where acceptingParser = fmap (UInt . fromInteger) parse+ simpleTypeText (UInt x) = show x instance SimpleType UnsignedShort where acceptingParser = fmap (UShort . fromInteger) parse+ simpleTypeText (UShort x) = show x instance SimpleType UnsignedByte where acceptingParser = fmap (UByte . fromInteger) parse+ simpleTypeText (UByte x) = show x instance SimpleType PositiveInteger where acceptingParser = fmap Positive parse+ simpleTypeText (Positive x) = show x
src/Text/XML/HaXml/Schema/Schema.hs view
@@ -25,6 +25,11 @@ , module Text.Parse -- , module Text.XML.HaXml.Schema.PrimitiveTypes , module Text.XML.HaXml.OneOfN+ , toXMLElement+ , toXMLText+ , toXMLAnyElement+ , toXMLAttribute+ , addXMLAttributes ) where import Text.ParserCombinators.Poly@@ -40,10 +45,11 @@ import Text.XML.HaXml.OneOfN import Text.XML.HaXml.Verbatim --- | A SchemaType is for element types, and has a parser from generic XML--- content tree to a Haskell value.+-- | A SchemaType promises to interconvert between a generic XML+-- content tree and a Haskell value, according to the rules of XSD. class SchemaType a where parseSchemaType :: String -> XMLParser a+ schemaTypeToXML :: String -> a -> [Content ()] -- | A type t can extend another type s by the addition of extra elements -- and/or attributes. s is therefore the supertype of t.@@ -70,6 +76,8 @@ (Right v, "") -> return v (Right v, _) -> return v -- ignore trailing text +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --+ -- | Between is a list parser that tries to ensure that any range -- specification (min and max elements) is obeyed when parsing. between :: PolyParse p => Occurs -> p a -> p [a]@@ -118,6 +126,7 @@ a == b = show a == show b instance SchemaType AnyElement where parseSchemaType _ = parseAnyElement+ schemaTypeToXML _ = toXMLAnyElement parseAnyElement :: XMLParser AnyElement parseAnyElement = fmap UnconvertedANY next@@ -127,7 +136,34 @@ parseText = text -- from XmlContent.Parser `onFail` return "" +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()]+toXMLElement name attrs content =+ [CElem (Elem (N name) (concat attrs) (concat content)) ()]++toXMLText :: String -> [Content ()]+toXMLText text =+ [CString False text ()]++toXMLAnyElement :: AnyElement -> [Content ()]+toXMLAnyElement (UnconvertedANY c) = [fmap (const ()) c]+--toXMLAnyElement (ANYSchemaType x) = [c]++toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute]+toXMLAttribute name val = [ (N name, AttValue [Left (simpleTypeText val)]) ]++-- | For a ComplexType that is an extension of a SimpleType, it is necessary to+-- convert the value to XML first, then add in the extra attributes that+-- constitute the extension.+addXMLAttributes :: [[Attribute]] -> [Content ()] -> [Content ()]+addXMLAttributes extra [CElem (Elem n attrs content) ()] =+ [CElem (Elem n (attrs++concat extra) content) ()]+addXMLAttributes _ x = x++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++ {- examples -------- @@ -142,13 +178,33 @@ c2 <- optional $ parseSchemaType "doodad" c3 <- between (Occurs (Just 3) (Just 5)) $ parseSchemaType "rinta"- return $ FpMLSomething a0 a1 c0 c1 c2 c3+ c4 <- fmap OneOf2 (parseSchemaType "left")+ `onFail`+ fmap TwoOf2 (parseSchemaType "right")+ return $ FpMLSomething a0 a1 c0 c1 c2 c3 c4+ schemaTypeToXML s x@FPMLSomething{} =+ toXMLElement s [ mkAttribute "flirble" (something_flirble x)+ , mkAttribute "binky" (something_binky x)+ ]+ [ schemaTypeToXML "foobar" (something_foobar x)+ , concatMap (schemaTypeToXML "quux") (something_quux x)+ , maybe [] (schemaTypeToXML "doodad") (something_doodad x)+ , concatMap (schemaTypeToXML "rinta") (something_rinta x)+ , foldOneOf2 (schemaTypeToXML "left")+ (schemaTypeToXML "right") (something_choice4 x)+ ] instance SimpleType FpMLNumber where acceptingParser = ...+ simpleTypeText = ... -} -#define SchemaInstance(TYPE) instance SchemaType TYPE where parseSchemaType s = do { e <- element [s]; interior e $ parseSimpleType; }++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++-- Ensure that all primitive/simple types can also be used as elements.++#define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e $ parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] } SchemaInstance(XsdString) SchemaInstance(Prim.Boolean)
src/Text/XML/HaXml/Schema/TypeConversion.hs view
@@ -14,7 +14,7 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.List (foldl')-import Data.Maybe (fromMaybe,fromJust,isNothing)+import Data.Maybe (fromMaybe,fromJust,isNothing,isJust) import Data.Monoid -- | Given an environment of schema type mappings, and a schema module,@@ -116,7 +116,7 @@ ExtendComplexTypeAbstract n ({-supertype-}XName $ extension_base e) ({-subtypes-}- maybe (error "ECTA")+ maybe (error ("ExtendComplexTypeAbstract "++show nx)) (map (\(t,l)->(XName t,if l/=myLoc then Just (xname l) else Nothing)))@@ -235,9 +235,11 @@ elementDecl :: XSD.ElementDecl -> Haskell.Element elementDecl ed = case elem_nameOrRef ed of Left n -> Element ({-name-}xname $ theName n)- ({-type-}maybe (xname $ theName n{-"unknownElement"-}) XName $ theType n)+ ({-type-}maybe (localTypeExp ed)+ XName+ (theType n)) ({-modifier-}Haskell.Range $ elem_occurs ed)- (isNothing $ theType n) -- by reference+ False -- by reference [] -- internal Decl Nothing -- substitution group (comment (elem_annotation ed))@@ -259,6 +261,25 @@ (Haskell.Range (elem_occurs ed)) True [] Nothing Nothing + localTypeExp :: XSD.ElementDecl -> XName+ localTypeExp ed | isJust (elem_content ed) =+ case fromJust (elem_content ed) of+ Left st@Primitive{} -> xname "SomethingPrimitive"+ Left st@Restricted{} -> (\x-> maybe x xname+ (simple_name st)) $+ (maybe (xname "GiveUp")+ XName $+ restrict_base $+ simple_restriction st)+ Left st@ListOf{} -> xname "SomethingListy"+ Left st@UnionOf{} -> xname "SomethingUnionLike"+ Right c@ComplexType{} -> xname $ fromMaybe "unknown"+ $ complex_name c+ | otherwise =+ case elem_nameOrRef ed of+ Left n -> xname $ theName n+ Right _ -> xname $ "unknownElement"+ attributeDecl :: XSD.AttributeDecl -> [Haskell.Attribute] attributeDecl ad = case attr_nameOrRef ad of Left n -> singleton $@@ -268,6 +289,7 @@ (attr_simpleType ad)) XName (theType n))+ (attr_use ad == Required) (comment (attr_annotation ad)) Right ref -> case Map.lookup ref (env_attribute env) of Nothing -> error $ "<attributeDecl> unknown attribute reference "
src/Text/XML/HaXml/Schema/XSDTypeModel.hs view
@@ -296,3 +296,12 @@ (Documentation d) `mappend` (Documentation e) = Documentation (d++"\n"++e) _ `mappend` (Documentation e) = Documentation e ann `mappend` _ = ann ++-- This instance is pretty unsatisfactory, and is useful only for+-- building environments involving recursive modules. The /mappend/+-- method is left-biased, and the /mempty/ value contains lots of+-- undefined values.+instance Monoid Schema where+ mempty = Schema{ schema_items=[] }+ s `mappend` t = s{ schema_items = schema_items s ++ schema_items t }+
src/Text/XML/HaXml/Types.hs view
@@ -171,7 +171,13 @@ -- ^ bool is whether whitespace is significant | CRef Reference i | CMisc Misc i- deriving Eq++-- custom instance of Eq, ignoring the informational elements.+instance Eq (Content i) where+ (CElem e _) == (CElem e' _) = e==e'+ (CString b c _) == (CString b' c' _) = b==b' && c==c'+ (CRef r _) == (CRef r' _) = r==r'+ (CMisc m _) == (CMisc m' _) = m==m' info :: Content t -> t info (CElem _ i) = i
src/Text/XML/HaXml/Validate.hs view
@@ -51,9 +51,17 @@ , attributes = listToFM [ ((elem,attr),typ) | AttList (AttListDecl elem attdefs) <- decls , AttDef attr typ _ <- attdefs ]- , required = listToFM [ (elem, [ attr- | AttDef attr _ REQUIRED <- attdefs ])- | AttList (AttListDecl elem attdefs) <- decls ]+ -- Be sure to look at all attribute declarations for each+ -- element, since we must merge them. This implements the+ -- specification in that regard only; the specification's rules+ -- about how to merge multiple declarations for the same+ -- attribute are not considered by this implementation.+ -- See: http://www.w3.org/TR/REC-xml/#NT-AttlistDecl+ , required = listToFM [ (elem, concat [ [ attr | AttDef attr _ REQUIRED <- attdefs ]+ | AttList (AttListDecl elem' attdefs) <- decls+ , elem' == elem ]+ )+ | Element (ElementDecl elem _) <- decls ] , ids = [ (elem,attr) | Element (ElementDecl elem _) <- decls , AttList (AttListDecl name attdefs) <- decls
src/Text/XML/HaXml/Verbatim.hs view
@@ -71,7 +71,9 @@ verbatim (CElem c _) = verbatim c verbatim (CString _ c _) = c verbatim (CRef c _) = verbatim c- verbatim (CMisc _ _) = error "NYI: verbatim not defined for CMisc"+ verbatim (CMisc (Comment c) _) = "<!--"++c++"-->"+ verbatim (CMisc _ _) = "<? ?>"+ -- verbatim (CMisc _ _) = error "NYI: verbatim not defined for CMisc" instance Verbatim (Element i) where verbatim (Elem nam att []) = "<" ++ qname nam
src/Text/XML/HaXml/XmlContent/Parser.hs view
@@ -192,7 +192,9 @@ | otherwise -> fail ("Too many elements inside <" ++printableName e++"> at\n" ++show (info d)++"\n"- ++"Found excess: "++verbatim d)+ ++"Found excess: "+ ++verbatim (take 7 ds)+ ++"\n[...]") where onlyMisc (CMisc _ _) = True onlyMisc (CString False s _) | all isSpace s = True onlyMisc _ = False
src/tools/DtdToHaskell.hs view
@@ -56,6 +56,7 @@ in do hPutStrLn o ("module "++realname ++" where\n\nimport Text.XML.HaXml.XmlContent"+ ++"\nimport Text.XML.HaXml.Types" ++"\nimport Text.XML.HaXml.OneOfN") -- ++"\nimport Char (isSpace)" -- ++"\nimport List (isPrefixOf)"
+ src/tools/FpMLToHaskell.hs view
@@ -0,0 +1,216 @@+-- FpMLToHaskell+module Main where++-- This program is designed to convert a bunch of XML files containing XSD+-- module decls into a bunch of Haskell modules containing data/newtype+-- definitions which mirror the XSD. Once you have used this program+-- to generate your type definitions, you should import Text.XML.HaXml.Schema+-- (as well as the generated modules) wherever you intend to read and write+-- XML files with your Haskell programs.++import System.Exit+import System.Environment+import System.IO+import Control.Monad+import System.Directory+import Data.List+import Data.Maybe (fromMaybe,catMaybes)+import Data.Function (on)+import Data.Monoid (mconcat)+--import Either++import Text.XML.HaXml (version)+import Text.XML.HaXml.Types+import Text.XML.HaXml.Namespaces (resolveAllNames,qualify+ ,nullNamespace)+import Text.XML.HaXml.Parse (xmlParse')+import Text.XML.HaXml.Util (docContent)+import Text.XML.HaXml.Posn (posInNewCxt)++import Text.XML.HaXml.Schema.Parse+import Text.XML.HaXml.Schema.XSDTypeModel (Schema)+import Text.XML.HaXml.Schema.NameConversion+import Text.XML.HaXml.Schema.Environment as Env+import Text.XML.HaXml.Schema.TypeConversion as XsdToH+import Text.XML.HaXml.Schema.PrettyHaskell+import qualified Text.XML.HaXml.Schema.PrettyHsBoot as HsBoot+import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell+import Text.ParserCombinators.Poly+import Text.PrettyPrint.HughesPJ (render,vcat)++fst3 :: (a,b,c) -> a+fst3 (a,_,_) = a++-- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html+argDirsToFiles :: IO (FilePath,[(FilePath,FilePath)])+argDirsToFiles = do+ args <- getArgs+ when ("--version" `elem` args) $ do+ putStrLn $ "part of HaXml-"++version+ exitWith ExitSuccess+ when ("--help" `elem` args) $ do+ putStrLn $ "Usage: FpMLToHaskell xsdDir haskellDir"+ putStrLn $ " -- The results go into haskelldir/Data/FpML/file0.hs etc"+ putStrLn $ "See http://haskell.org/HaXml"+ exitWith ExitSuccess+ case args of+ [xsddir,hdir]-> do+ files <- fmap (filter (".xsd" `isSuffixOf`))+ (getDirectoryContents xsddir)+ let newdirs = map (\file->hdir++"/"++dirOf (fpml file)) files+ mapM_ (\newdir -> do createDirectoryIfMissing True newdir) newdirs+ return (xsddir+ ,map (\f-> (f, hdir++"/"++(reslash (fpml f))++".hs")) files)+ _ -> do prog <- getProgName+ putStrLn ("Usage: "++prog++" xsdDir haskellDir")+ exitFailure+ where+ reslash = map (\c-> case c of '.'->'/'; _->c)+ dirOf = concat . intersperse "/" . init . wordsBy '.'+ wordsBy c s = let (a,b) = span (/=c) s in+ if null b then [a] else a: wordsBy c (tail b)++main ::IO ()+main = do+ (dir,files) <- argDirsToFiles+ deps <- flip mapM files (\ (inf,outf)-> do+ hPutStrLn stdout $ "Reading "++inf+ thiscontent <- readFile (dir++"/"++inf)+ let d@Document{} = resolveAllNames qualify+ . either (error . ("not XML:\n"++)) id+ . xmlParse' inf+ $ thiscontent+ case runParser schema [docContent (posInNewCxt inf Nothing) d] of+ (Left msg,_) -> do hPutStrLn stderr msg+ return ([], undefined)+ (Right v,[]) -> return (Env.gatherImports v, v)+ (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!"+ hPutStrLn stdout $ inf+ hPutStrLn stdout $ "\n-----------------\n"+ hPutStrLn stdout $ show v+ hPutStrLn stdout $ "\n-----------------\n"+ return ([],v)+ )+ let filedeps :: [[((FilePath,FilePath),([(FilePath,Maybe String)],Schema))]]+ filedeps = ordered (\ ((inf,_),_)-> inf)+ (\ (_,(ds,_))-> map fst ds)+ (\x-> lookupWith (fst.fst) x (zip files deps))+ (zip files deps)+ -- a single supertype environment, closed over all modules+ supertypeEnv :: Environment+ supertypeEnv = foldr (\fs e->+ foldr (\((inf,_),(_,v))-> mkEnvironment inf v)+ e fs)+ emptyEnv filedeps+ adjust :: Environment -> Environment+ adjust env = env{ env_extendty = env_extendty supertypeEnv+ , env_substGrp = env_substGrp supertypeEnv+ , env_allTypes = env_allTypes supertypeEnv }+ -- each module's env includes only dependencies, apart from supertypes+ environs :: [(FilePath,(Environment,FilePath,Schema))]+ environs = flip concatMap filedeps $ \scc->+ case scc of+ [((inf,outf),(ds,v))]->+ [(inf, ( adjust $ mkEnvironment inf v+ (foldr combineEnv emptyEnv+ (flip map ds+ (\d-> fst3 $+ fromMaybe (error "FME") $+ lookup (fst d) environs)+ )+ )+ , outf+ , v+ )+ )]+ cyclic ->+ let jointSchema :: Schema+ jointSchema = mconcat (map (snd.snd) cyclic)+ jointDeps :: [FilePath]+ jointDeps = concatMap (map fst.fst.snd) cyclic+ jointEnv :: Environment+ jointEnv = mkEnvironment "" jointSchema $+ foldr combineEnv emptyEnv $+ flip map (nub jointDeps+ \\ map (fst.fst) cyclic)+ (\d-> fst3 $+ fromMaybe (error "FME") $+ lookup d environs)+ in flip map cyclic+ (\((inf,outf),(_,v))->+ (inf,(adjust $ mkEnvironment inf v+ $ jointEnv+ ,outf+ ,v)+ )+ )+ flip mapM_ environs (\ (inf,(env,outf,v))-> do+ o <- openFile outf WriteMode+ hb <- openFile (bootf outf) WriteMode+ let decls = XsdToH.convert env v+ haskell = Haskell.mkModule inf v decls+ doc = ppModule fpmlNameConverter haskell+ docboot = HsBoot.ppModule fpmlNameConverter haskell+ hPutStrLn stdout $ "Writing "++outf+ hPutStrLn o $ render doc+ hPutStrLn stdout $ "Writing "++(bootf outf)+ hPutStrLn hb $ render docboot+ hFlush o+ hFlush hb+ )++-- | Munge filename for hs-boot.+bootf :: FilePath -> FilePath+bootf x = case reverse x of+ 's':'h':'.':f -> reverse f++".hs-boot"+ _ -> error "bad stuff made my cheese boots melt"++-- | Calculate dependency ordering of modules, least dependent first.+-- Cyclic groups may occur, suitably placed in the ordering.+ordered :: (Eq a, Eq b) => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]]+ordered name deps env list =+ let cycles = cyclicDeps name deps env list+ noncyclic = map (:[]) $ list \\ concat cycles+ workqueue = noncyclic++cycles+ in traverse [] workqueue+ where+ traverse acc [] = acc+ traverse acc (w:wq) = if all (`elem` concatMap (map name) acc)+ (concatMap deps w \\ map name w)+ then traverse (acc++[w]) wq+ else traverse acc (wq++[w])++-- | Find cyclic dependencies between modules.+cyclicDeps :: Eq a => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]]+cyclicDeps name deps env = nubBy (setEq`on`map name)+ . (\cs-> foldl minimal cs cs)+ . concatMap (walk [])+ where+-- walk :: [b] -> b -> [[b]]+ walk acc t = if name t `elem` map name acc then [acc]+ else concatMap (walk (t:acc)) (catMaybes . map env $ deps t)+ minimal acc c = concatMap (prune c) acc+ prune c c' = if map name c `isProperSubsetOf` map name c' then [] else [c']+ isSubsetOf a b = all (`elem`b) a+ setEq a b = a`isSubsetOf`b && b`isSubsetOf`a+ isProperSubsetOf a b = a`isSubsetOf`b && not (b`isSubsetOf`a)++-- | A variation on the standard lookup function.+lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b+lookupWith proj x [] = Nothing+lookupWith proj x (y:ys) | proj y == x = Just y+ | otherwise = lookupWith proj x ys++-- | What is the targetNamespace of the unique top-level element?+targetNamespace :: Element i -> String+targetNamespace (Elem qn attrs _) =+ if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag"+ else case lookup (N "targetNamespace") attrs of+ Nothing -> "ERROR! no targetNamespace specified"+ Just atv -> show atv++-- | The XSD Namespace.+xsdSchema :: QName+xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"})+ "schema"+
src/tools/MkOneOf.hs view
@@ -39,11 +39,11 @@ [1..n] (take n variables)) ++ "\n deriving (Eq,Show)"- ++ "\n\ninstance "++ format 10 78 10 "(" ","+ ++ "\n\ninstance "++ format 9 78 9 "(" "," (map ("HTypeable "++) (take n variables)) ++ ")\n => HTypeable ("++ typename n 26 ++")\n where"- ++ " toHType m = Defined \""++constructor 1 n++"\" [] []"- ++ "\n\ninstance "++ format 10 78 10 "(" ","+ ++ " toHType _ = Defined \""++constructor 1 n++"\" [] []"+ ++ "\n\ninstance "++ format 9 78 9 "(" "," (map ("XmlContent "++) (take n variables)) ++ ")\n => XmlContent ("++ typename n 26 ++")\n where" ++ "\n parseContents ="@@ -53,6 +53,17 @@ ++ concatMap (\v->"\n toContents ("++constructor v n ++" x) = toContents x") [1..n]+ ++ "\n\nfold"++constructor 1 n++" :: "+ ++format 15 78 15 "" ""+ (map (\v->"("++v++"->z) -> ") (take n variables))+ ++"\n "+ ++constructor 1 n++format 22 78 22 " " " " (take n variables)+ ++"\n -> z"+ ++ concat (zipWith (\i v-> "\n"++"fold"++constructor 1 n+ ++format 11 50 11 " " " " (take n variables)+ ++" ("++constructor i n ++" z) = "++v++" z")+ [1..n]+ (take n variables)) ++ "\n\n----" ---- constructor names ----@@ -73,7 +84,7 @@ ---- variable names ---- variables :: [String]-variables = [ v:[] | v <- ['a'..'z']]+variables = [ v:[] | v <- ['a'..'y']] ++ [ v:w:[] | v <- ['a'..'z'], w <- ['a'..'z']] ---- simple pretty-printing ----