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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{-# OPTIONS -fglasgow-exts #-}
module XML (tests) where
{-
This example illustrates XMLish services
to trealise (say, "serialise") heterogenous
Haskell data as homogeneous tree structures
(say, XMLish elements) and vice versa.
-}
import Test.HUnit
import Control.Applicative (Alternative(..), Applicative(..))
import Control.Monad
import Data.Maybe
import Data.Generics
import CompanyDatatypes
-- HaXml-like types for XML elements
data Element = Elem Name [Attribute] [Content]
deriving (Show, Eq, Typeable, Data)
data Content = CElem Element
| CString Bool CharData
-- ^ bool is whether whitespace is significant
| CRef Reference
| CMisc Misc
deriving (Show, Eq, Typeable, Data)
type CharData = String
-- In this simple example we disable some parts of XML
type Attribute = ()
type Reference = ()
type Misc = ()
-- Trealisation
data2content :: Data a => a -> [Content]
data2content = element
`ext1Q` list
`extQ` string
`extQ` float
where
-- Handle an element
element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))
[] -- no attributes
(concat (gmapQ data2content x)))]
-- A special case for lists
list :: Data a => [a] -> [Content]
list = concat . map data2content
-- A special case for strings
string :: String -> [Content]
string x = [CString True x]
-- A special case for floats
float :: Float -> [Content]
float x = [CString True (show x)]
-- De-trealisation
content2data :: forall a. Data a => ReadX a
content2data = result
where
-- Case-discriminating worker
result = element
`ext1R` list
`extR` string
`extR` float
-- Determine type of data to be constructed
myType = myTypeOf result
where
myTypeOf :: forall a. ReadX a -> a
myTypeOf = undefined
-- Handle an element
element = do c <- readX
case c of
(CElem (Elem x as cs))
| as == [] -- no attributes
&& x == (tyconUQname (dataTypeName (dataTypeOf myType)))
-> alts cs
_ -> mzero
-- A special case for lists
list :: forall a. Data a => ReadX [a]
list = ( do h <- content2data
t <- list
return (h:t) )
`mplus` return []
-- Fold over all alternatives, say constructors
alts cs = foldr (mplus . recurse cs) mzero shapes
-- Possible top-level shapes
shapes = map fromConstr consOf
-- Retrieve all constructors of the requested type
consOf = dataTypeConstrs
$ dataTypeOf
$ myType
-- Recurse into subterms
recurse cs x = maybe mzero
return
(runReadX (gmapM (const content2data) x) cs)
-- A special case for strings
string :: ReadX String
string = do c <- readX
case c of
(CString _ x) -> return x
_ -> mzero
-- A special case for floats
float :: ReadX Float
float = do c <- readX
case c of
(CString _ x) -> return (read x)
_ -> mzero
-----------------------------------------------------------------------------
--
-- An XML-hungry parser-like monad
--
-----------------------------------------------------------------------------
-- Type constructor
newtype ReadX a =
ReadX { unReadX :: [Content]
-> Maybe ([Content], a) }
-- Run a computation
runReadX x y = case unReadX x y of
Just ([],y) -> Just y
_ -> Nothing
-- Read one content particle
readX :: ReadX Content
readX = ReadX (\x -> if null x
then Nothing
else Just (tail x, head x)
)
instance Functor ReadX where
fmap = liftM
instance Applicative ReadX where
pure = return
(<*>) = ap
instance Alternative ReadX where
(<|>) = mplus
empty = mzero
-- ReadX is a monad!
instance Monad ReadX where
return x = ReadX (\y -> Just (y,x))
c >>= f = ReadX (\x -> case unReadX c x of
Nothing -> Nothing
Just (x', a) -> unReadX (f a) x'
)
-- ReadX also accommodates mzero and mplus!
instance MonadPlus ReadX where
mzero = ReadX (const Nothing)
f `mplus` g = ReadX (\x -> case unReadX f x of
Nothing -> unReadX g x
y -> y
)
-----------------------------------------------------------------------------
--
-- Main function for testing
--
-----------------------------------------------------------------------------
tests = ( genCom
, ( data2content genCom
, ( zigzag person1 :: Maybe Person
, ( zigzag genCom :: Maybe Company
, ( zigzag genCom == Just genCom
))))) ~=? output
where
-- Trealise back and forth
zigzag :: Data a => a -> Maybe a
zigzag = runReadX content2data . data2content
output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))
|
