1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
GADTs, RankNTypes, FlexibleContexts, TypeSynonymInstances,
MultiParamTypeClasses, DeriveDataTypeable, PatternGuards,
OverlappingInstances, UndecidableInstances, CPP #-}
module T1735_Help.Xml (Element(..), Xml, fromXml) where
import T1735_Help.Basics
import T1735_Help.Instances ()
import T1735_Help.State
data Element = Elem String [Element]
| CData String
| Attr String String
fromXml :: Xml a => [Element] -> Maybe a
fromXml xs = case readXml xs of
Just (_, v) -> return v
Nothing -> error "XXX"
class (Data XmlD a) => Xml a where
toXml :: a -> [Element]
toXml = defaultToXml
readXml :: [Element] -> Maybe ([Element], a)
readXml = defaultReadXml
readXml' :: [Element] -> Maybe ([Element], a)
readXml' = defaultReadXml'
instance (Data XmlD t, Show t) => Xml t
data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }
xmlProxy :: Proxy XmlD
xmlProxy = error "xmlProxy"
instance Xml t => Sat (XmlD t) where
dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }
defaultToXml :: Xml t => t -> [Element]
defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]
transparentToXml :: Xml t => t -> [Element]
transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x
-- Don't do any defaulting here, as these functions can be implemented
-- differently by the user. We do the defaulting elsewhere instead.
-- The t' type is thus not used.
defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml es = readXml' es
defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml' = readXmlWith readVersionedElement
readXmlWith :: Xml t
=> (Element -> Maybe t)
-> [Element]
-> Maybe ([Element], t)
readXmlWith f es = case es of
e : es' ->
case f e of
Just v -> Just (es', v)
Nothing -> Nothing
[] ->
Nothing
readVersionedElement :: forall t . Xml t => Element -> Maybe t
readVersionedElement e = readElement e
readElement :: forall t . Xml t => Element -> Maybe t
readElement (Elem n es) = res
where resType :: t
resType = typeNotValue resType
resDataType = dataTypeOf xmlProxy resType
con = readConstr resDataType n
res = case con of
Just c -> f c
Nothing -> Nothing
f c = let m :: Maybe ([Element], t)
m = constrFromElements c es
in case m of
Just ([], x) -> Just x
_ -> Nothing
readElement _ = Nothing
constrFromElements :: forall t . Xml t
=> Constr -> [Element] -> Maybe ([Element], t)
constrFromElements c es
= do let st = ReadState { xmls = es }
m :: ReadM Maybe t
m = fromConstrM xmlProxy (readMXmlD dict) c
-- XXX Should we flip the result order?
(x, st') <- runStateT m st
return (xmls st', x)
type ReadM m = StateT ReadState m
data ReadState = ReadState {
xmls :: [Element]
}
getXmls :: Monad m => ReadM m [Element]
getXmls = do st <- get
return $ xmls st
putXmls :: Monad m => [Element] -> ReadM m ()
putXmls xs = do st <- get
put $ st { xmls = xs }
readMXml :: Xml a => ReadM Maybe a
readMXml
= do xs <- getXmls
case readXml xs of
Nothing -> fail "Cannot read value"
Just (xs', v) ->
do putXmls xs'
return v
typeNotValue :: Xml a => a -> a
typeNotValue t = error ("Type used as value: " ++ typeName)
where typeName = dataTypeName (dataTypeOf xmlProxy t)
-- The Xml [a] context is a bit scary, but if we don't have it then
-- GHC complains about overlapping instances
instance (Xml a {-, Xml [a] -}) => Xml [a] where
toXml = concatMap toXml
readXml = f [] []
where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
f acc_xs acc_vs (x:xs) = case readXml [x] of
Just ([], v) ->
f acc_xs (v:acc_vs) xs
_ ->
f (x:acc_xs) acc_vs xs
instance Xml String where
toXml x = [CData x]
readXml = readXmlWith f
where f (CData x) = Just x
f _ = Nothing
|
