@@ -2,13 +2,81 @@ module Text.XSD.Parser where
22
33import Control.Exception
44import Control.Monad
5+import Control.Monad.Error
6+import Control.Monad.Trans.Reader
57import 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
713import Text.XSD.Internal as XSD
814
915
10−toXsd :: Document -> Either SomeException XSD.Element
11−toXsd = undefined
16+newtype XSDException = XSDException String
17+ deriving (Show)
18+
19+instance Exception XSDException
20+
21+type XSDMonad a = ReaderT (M.Map Name Datatype) (Either SomeException) a
1222
1323parseXSD :: 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