git.iko.soy/typeable/xsd-parser
on master help sign in
Initial datatype spec
d5be8ebDenis Redozubov
src/Text/XSD/Internal.hs+101−4
compare with master
unifiedsplit
@@ -5,13 +5,110 @@ module Text.XSD.Internal where
5
5
6import Control.Lens
6import Control.Lens
7import Data.Text
7import Data.Text
8+import Data.Map as M
9+
10+
11+-- | Roughly based on https://www.w3.org/TR/xmlschema11-2/#built-in-datatypes
12+data Datatype
13+ = ComplexType ComplexType
14+ | SimpleType SimpleType
15+ deriving (Show)
16+
17+-- | Based on https://www.w3.org/TR/xmlschema11-1/#dcl.ctd.ctsc
18+-- Only sequence and choice are supported
19+data ComplexType
20+ = CTSequence
21+ | CTChoice
22+ deriving (Show)
23+
24+-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
25+data SimpleType
26+ = STAnyURI
27+ | STBase64Binary
28+ | STBoolean
29+ | STDate
30+ | STDateTime
31+ | STDecimal DecimalType
32+ | STDouble
33+ | STDuration DurationType
34+ | STFloat
35+ | STGDay
36+ | STGMonth
37+ | STGMonthDay
38+ | STGYear
39+ | STGYearMonth
40+ | STHexBinary
41+ | STNOTATION
42+ | STQName QName
43+ | STString StringType
44+ | STTime
45+ | STUnion -- special - xs:union
46+ | STList -- special - xs:list
47+ deriving (Show)
48+
49+data StringType
50+ = StrNormalizedString
51+ | StrToken
52+ | StrLanguage
53+ | StrName
54+ | StrNCNAME
55+ | StrENTITY
56+ | StrID
57+ | StrIDREF
58+ | StrNMTOKEN
59+ deriving (Show)
60+
61+data DurationType = DayTimeDuration | YearMonthDuration deriving (Show, Eq)
62+
63+data DecimalType
64+ = DTInteger
65+ | DTLong
66+ | DTInt
67+ | DTShort
68+ | DTByte
69+ | DTNonNegativeInteger
70+ | DTPositiveInteger
71+ | DTUnsignedLong
72+ | DTUnsignedInt
73+ | DTUnsignedShort
74+ | DTUnsignedByte
75+ | DTNonPositiveInteger
76+ | DTNegativeInteger
77+ deriving (Show, Eq)
78+
79+type LocalName = Text
80+
81+type Namespace = Text
82+
83+type QName = (Namespace, LocalName)
84+
85+-- data Definition
86+-- = XSString
87+-- | XSSeq [Definition]
88+-- | XSChoice [Definition]
89+-- deriving (Show)
8
90
9type Attribute = (Text, Text)
91type Attribute = (Text, Text)
10
92
93+-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model
94+-- Secondary and helper schema components are not supported right now.
95+data SchemaComponent
96+ = SCSimpleType SimpleType
97+ | SCComplexType ComplexType
98+ | SCElement Element
99+ | SCAttribute
100+ deriving (Show)
101+
11data Element = Element
102data Element = Element
103+ { name :: String
104+ , target :: Maybe Namespace
105+ , xtype :: Datatype
12− { _attrs :: [Attribute]
106+ , attrs :: [Attribute]
107+ , abstract :: Bool
13− , _elements :: [Element] }
108+ , elements :: [Element]
14− | Choice Element Element
109+ }
15 deriving (Show)
110 deriving (Show)
16
111
17−makeLenses ''Element
112+-- | Embodies an XSD document
113+newtype XSD = XSD { unXSD :: Element }
114+ deriving (Show)
src/Text/XSD/Parser.hs+72−4
@@ -2,13 +2,81 @@ module Text.XSD.Parser where
2
2
3import Control.Exception
3import Control.Exception
4import Control.Monad
4import Control.Monad
5+import Control.Monad.Error
6+import Control.Monad.Trans.Reader
5import Data.ByteString.Lazy
7import Data.ByteString.Lazy
6−import Text.XML
8+import Data.Map as M
9+import Data.Text
10+import Prelude as P
11+import Text.XML as XML
12+import Text.XML.Cursor as XML
7import Text.XSD.Internal as XSD
13import Text.XSD.Internal as XSD
8
14
9
15
10−toXsd :: Document -> Either SomeException XSD.Element
16+newtype XSDException = XSDException String
11−toXsd = undefined
17+ deriving (Show)
18+
19+instance Exception XSDException
20+
21+type XSDMonad a = ReaderT (M.Map Name Datatype) (Either SomeException) a
12
22
13parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD.Element
23parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD.Element
14−parseXSD ps bs = toXsd =<< parseLBS ps bs
24+parseXSD ps bs = parseLBS ps bs >>= toXsd
25+
26+data Expectation
27+ = ExpName Text
28+ | Expectation :+: Expectation
29+
30+satisfy :: Expectation -> XML.Node -> Bool
31+satisfy exp node@(NodeElement (XML.Element name _ _)) =
32+ case node of
33+ NodeElement (XML.Element (Name name _ _) _ _) -> case exp of
34+ ExpName n -> name == n
35+ exp1 :+: exp2 -> satisfy exp1 node && satisfy exp2 node
36+
37+satisfySome
38+ :: XML.Cursor
39+ -> [Expectation]
40+ -> Bool
41+satisfySome c e = satisfySome' True c e
42+
43+satisfySome'
44+ :: Bool -- ^ check current
45+ -> XML.Cursor
46+ -> [Expectation]
47+ -> Bool
48+satisfySome' checkCurrent cur [] = True
49+satisfySome' checkCurrent cur (exp:exps) = result
50+ where
51+ satisfyCurrent = satisfy exp (node cur)
52+ validChildren = P.filter (satisfy (P.head exps) . node) (child cur)
53+ result =
54+ if checkCurrent && P.null exps
55+ then satisfyCurrent
56+ else P.foldr (\c r -> r && satisfySome' False c exps) True validChildren
57+
58+-- Show is Meh
59+throwXsd :: Show s => s -> XSDMonad a
60+throwXsd = throwError . SomeException . XSDException . show
61+
62+toSchema :: XML.Node -> [XSD.Element] -> XSDMonad XSD
63+toSchema (XML.NodeElement (XML.Element (Name name _ _) _ _)) elems
64+ | name == "schema" = pure $ XSD $ XSD.Element (XSSeq []) "schema" [] elems
65+ | otherwise = throwXsd "Top-level schema definition not found"
66+
67+fromElem :: XML.Cursor -> XSDMonad XSD.Element
68+fromElem cursor = do
69+ case node cursor of
70+ NodeElement el -> case nameLocalName (elementName el) of
71+ "element" -> do
72+
73+ "simpleType" -> error "TODO: implement"
74+ e ->
75+ throwXsd $ "xsd node not supported: " <> show e
76+
77+toXsd :: Document -> Either SomeException XSD.Element
78+toXsd doc = do
79+ let
80+ cursor = fromDocument doc
81+ elems = child cursor &| fromElem
82+ runReader M.null $ toSchema (node cursor) elems
xsd-isogen.cabal+26
@@ -23,13 +23,17 @@ library
23 , Text.XSD.Parser
23 , Text.XSD.Parser
24 , Text.XSD.Internal
24 , Text.XSD.Internal
25
25
26+ default-extensions: OverloadedStrings
26 other-extensions: TemplateHaskell
27 other-extensions: TemplateHaskell
27
28
28 -- Other library packages from which modules are imported.
29 -- Other library packages from which modules are imported.
29 build-depends: base ^>=4.12.0.0
30 build-depends: base ^>=4.12.0.0
30 , bytestring
31 , bytestring
32+ , containers
31 , lens >= 4.13
33 , lens >= 4.13
34+ , mtl
32 , text
35 , text
36+ , transformers
33 , xml-conduit
37 , xml-conduit
34
38
35 -- Directories containing source files.
39 -- Directories containing source files.
@@ -37,3 +41,25 @@ library
37
41
38 -- Base language which the package is written in.
42 -- Base language which the package is written in.
39 default-language: Haskell2010
43 default-language: Haskell2010
44+
45+test-suite spec
46+ type: exitcode-stdio-1.0
47+ hs-source-dirs: test
48+ main-is: Main.hs
49+ build-depends: base
50+ , bytestring
51+ , hspec
52+ , transformers
53+ , xml-conduit
54+ , xsd-isogen
55+ default-language: Haskell2010
56+ default-extensions: CPP
57+ , DeriveGeneric
58+ , FlexibleInstances
59+ , LambdaCase
60+ , OverloadedStrings
61+ , StandaloneDeriving
62+ , TemplateHaskell
63+ , TupleSections
64+ , TypeFamilies
65+ ghc-options: -Wall -fno-warn-missing-signatures