@@ -1,3 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
14module Text.XSD.Parser where
25
36import Control.Exception
@@ -23,10 +26,10 @@ newtype XSDException = XSDException String
2326
2427instance Exception XSDException
2528
26−type XSDMonad a = WriterT (M.Map Text Datatype) (Either SomeException) a
29+type XSDMonad a = WriterT DatatypeMap (Either SomeException) a
2730
2831parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD
29−parseXSD ps bs = parseLBS ps bs >>= fmap fst . toXsd
32+parseXSD ps bs = parseLBS ps bs >>= toXsd
3033
3134-- Show is Meh
3235throwXsd :: Show s => s -> XSDMonad a
@@ -51,13 +54,6 @@ toElemsAndDatatypes cursor = do
5154 throwXsd $ "unnamed type ref for datatype: " <> show datatype
5255 pure elems
5356
54−toSchema :: XML.Cursor -> XSDMonad XSD
55−toSchema cursor = do
56− let topLevel = cursor $| laxElement "schema"
57− if P.null topLevel
58− then throwXsd "Top-level schema definition not found"
59− else XSD <$> toElemsAndDatatypes cursor
60−
6157safeHead :: [a] -> Maybe a
6258safeHead [] = Nothing
6359safeHead (a:_) = Just a
@@ -74,6 +70,9 @@ toElem cursor = do
7470 ns = nameNamespace $ elementName el
7571 name <- attrThrowXsd "name" el
7672 $ "Expected attribute 'name' for element: " <> show (node cursor)
73+ let
74+ minOc = maybe 0 (read . T.unpack) (M.lookup "minOccurs" attrs)
75+ maxOc = read . T.unpack <$> M.lookup "maxOccurs" attrs
7776 datatypeRef <- case mAttrType of
7877 Just dtn -> pure $ DatatypeRef dtn
7978 Nothing -> do
@@ -86,8 +85,10 @@ toElem cursor = do
8685 let name = safeHead $ childCursor $| attribute "name"
8786 InlineComplex . TypeComplex <$> toComplexType childCursor
8887 pure $ XSD.Element
89− { name = (ns, name)
90− , xtype = datatypeRef }
88+ { name = (ns, name)
89+ , xtype = datatypeRef
90+ , minOccurs = minOc
91+ , maxOccurs = maxOc }
9192 e -> throwXsd $ "[toElem] xsd node not supported: " <> show e
9293 e ->
9394 throwXsd $ "[toElem] element expected, got: " <> show e
@@ -174,5 +175,11 @@ toAttribute cursor = do
174175 Nothing -> Optional
175176 pure $ Attribute name simpleType useProp
176177
177−toXsd :: Document -> Either SomeException (XSD, M.Map Text Datatype)
178−toXsd doc = runWriterT $ toSchema (fromDocument doc)
178+toXsd :: Document -> Either SomeException XSD
179+toXsd doc = do
180+ let cursor = fromDocument doc
181+ XSD <$> (runWriterT $ do
182+ let topLevel = cursor $| laxElement "schema"
183+ if P.null topLevel
184+ then throwXsd "Top-level schema definition not found"
185+ else toElemsAndDatatypes cursor)