@@ -2,10 +2,13 @@ module Text.XSD.Parser where
22
33import Control.Exception
44import Control.Monad
5−import Control.Monad.Error
5+import Control.Monad.Except (throwError)
66import Control.Monad.Trans.Reader
7+import Control.Monad.Writer.CPS
78import Data.ByteString.Lazy
9+import Data.Foldable
810import Data.Map as M
11+import Data.Maybe
912import Data.Text
1013import Prelude as P
1114import Text.XML as XML
@@ -18,7 +21,7 @@ newtype XSDException = XSDException String
1821
1922instance Exception XSDException
2023
21−type XSDMonad a = ReaderT (M.Map Name Datatype) (Either SomeException) a
24+type XSDMonad a = WriterT (M.Map Text Datatype) (Either SomeException) a
2225
2326parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD.Element
2427parseXSD ps bs = parseLBS ps bs >>= toXsd
@@ -59,24 +62,96 @@ satisfySome' checkCurrent cur (exp:exps) = result
5962throwXsd :: Show s => s -> XSDMonad a
6063throwXsd = throwError . SomeException . XSDException . show
6164
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"
65+maybeThrowXsd :: Show s => Maybe a -> s -> XSDMonad a
66+maybeThrowXsd (Just a) _ = pure a
67+maybeThrowXsd Nothing e = throwXsd e
6668
67−fromElem :: XML.Cursor -> XSDMonad XSD.Element
68−fromElem cursor = do
69+attrThrowXsd :: Show s => XML.Name -> XML.Element -> s -> XSDMonad Text
70+attrThrowXsd name elNode = maybeThrowXsd (M.lookup name $ elementAttributes elNode)
71+
72+-- | Tells the writer about named complex types and returns a list of elements.
73+toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]
74+toElemsAndDatatypes cursor = do
75+ elems <- traverse toElem (cursor $// laxElement "element")
76+ datatypes <- traverse toDatatype (cursor $// laxElement "complexType")
77+ for_ datatypes $ \case
78+ datatype@(ComplexType (Just name) _ _) -> tell (M.singleton name datatype)
79+ datatype@(ComplexType Nothing _ _) ->
80+ throwXsd $ "unnamed type ref for datatype: " <> show datatype
81+ pure elems
82+
83+toSchema :: XML.Cursor -> XSDMonad XSD
84+toSchema cursor = do
85+ let topLevel = cursor $| laxElement "schema"
86+ if P.null topLevel
87+ then throwXsd "Top-level schema definition not found"
88+ else XSD <$> toElemsAndDatatypes cursor
89+
90+safeHead :: [a] -> Maybe a
91+safeHead [] = Nothing
92+safeHead (a:_) = Just a
93+
94+toElem :: Cursor -> XSDMonad XSD.Element
95+toElem cursor = do
6996 case node cursor of
7097 NodeElement el -> case nameLocalName (elementName el) of
7198 "element" -> do
99+ let
100+ attrs = elementAttributes el
101+ mAttrType = M.lookup "type" attrs
102+ ns = nameNamespace $ elementName el
103+ name <- attrThrowXsd "name" el
104+ $ "Expected attribute 'name' for element: " <> show (node cursor)
105+ datatypeRef <- case mAttrType of
106+ Just dtn -> pure $ DatatypeRef dtn
107+ Nothing -> do
108+ onlyChildCursor <- maybeThrowXsd
109+ (safeHead $ cursor $// laxElement "simpleType")
110+ $ "Only one type child element expected for element: " <> show name
111+ InlineComplex <$> toDatatype onlyChildCursor
112+ pure $ XSD.Element
113+ { name = (ns, name)
114+ , xtype = datatypeRef }
115+ e -> throwXsd $ "xsd node not supported: " <> show e
116+ e ->
117+ throwXsd $ "element expected, got: " <> show e
72118
73− "simpleType" -> error "TODO: implement"
119+-- | Returns 'Just element' if encounters an element,
120+toDatatype :: Cursor -> XSDMonad Datatype
121+toDatatype cursor = do
122+ case node cursor of
123+ NodeElement el -> case nameLocalName (elementName el) of
124+ "simpleType" -> do
125+ error "implement simpleType"
126+ "complexType" -> do
127+ let sequenceAxis = laxElement "complexType" &// laxElement "sequence"
128+ let choiceAxis = laxElement "complexType" &// laxElement "choice"
129+ let allAxis = laxElement "complexType" &// laxElement "all"
130+ if P.null (cursor $// sequenceAxis)
131+ then if P.null (cursor $// choiceAxis)
132+ then if P.null (cursor $// allAxis)
133+ then throwXsd $ "No definition found for complexType: "
134+ <> show (safeHead $ cursor $// laxElement "complexType")
135+ else do
136+ childCursor <- maybeThrowXsd (safeHead $ cursor $// allAxis)
137+ $ "More than one xs:all tag in: "
138+ <> show (cursor $// laxElement "complexType")
139+ ComplexType Nothing CTAll <$> toElemsAndDatatypes childCursor
140+ else do
141+ childCursor <- maybeThrowXsd (safeHead $ cursor $// choiceAxis)
142+ $ "More than one xs:choice tag in: "
143+ <> show (cursor $// laxElement "complexType")
144+ ComplexType Nothing CTChoice <$> toElemsAndDatatypes childCursor
145+ else do
146+ childCursor <- maybeThrowXsd (safeHead $ cursor $// sequenceAxis)
147+ $ "More than one xs:sequence tag in: "
148+ <> show (cursor $// laxElement "complexType")
149+ ComplexType Nothing CTSequence <$> toElemsAndDatatypes childCursor
150+ e -> throwXsd $ "xsd node not supported: " <> show e
74151 e ->
75− throwXsd $ "xsd node not supported: " <> show e
152+ throwXsd $ "element expected, got: " <> show e
76153
77154toXsd :: Document -> Either SomeException XSD.Element
78155toXsd doc = do
79− let
80− cursor = fromDocument doc
81− elems = child cursor &| fromElem
82− runReader M.null $ toSchema (node cursor) elems
156+ (dt, el) <- runWriterT $ toSchema (fromDocument doc)
157+ error "implement me"