1{-# OPTIONS -fglasgow-exts #-}
2
3module XML (tests) where
4
5{-
6
7This example illustrates XMLish services
8to trealise (say, "serialise") heterogenous
9Haskell data as homogeneous tree structures
10(say, XMLish elements) and vice versa.
11
12-}
13
14import Test.HUnit
15
16import Control.Applicative (Alternative(..), Applicative(..))
17import Control.Monad
18import Data.Maybe
19import Data.Generics
20import CompanyDatatypes
21
22
23-- HaXml-like types for XML elements
24data Element   = Elem Name [Attribute] [Content]
25                 deriving (Show, Eq, Typeable, Data)
26
27data Content   = CElem Element
28               | CString Bool CharData
29                        -- ^ bool is whether whitespace is significant
30               | CRef Reference
31               | CMisc Misc
32                 deriving (Show, Eq, Typeable, Data)
33
34type CharData = String
35
36
37-- In this simple example we disable some parts of XML
38type Attribute = ()
39type Reference = ()
40type Misc      = ()
41
42
43-- Trealisation
44data2content :: Data a => a -> [Content]
45data2content =         element
46               `ext1Q` list
47               `extQ`  string
48               `extQ`  float
49
50 where
51
52  -- Handle an element
53  element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))
54                           [] -- no attributes
55                           (concat (gmapQ data2content x)))]
56
57  -- A special case for lists
58  list :: Data a => [a] -> [Content]
59  list = concat . map data2content
60
61  -- A special case for strings
62  string :: String -> [Content]
63  string x = [CString True x]
64
65  -- A special case for floats
66  float :: Float -> [Content]
67  float x = [CString True (show x)]
68
69
70-- De-trealisation
71content2data :: forall a. Data a => ReadX a
72content2data = result
73
74 where
75
76  -- Case-discriminating worker
77  result =         element
78           `ext1R` list
79           `extR`  string
80           `extR`  float
81
82
83  -- Determine type of data to be constructed
84  myType = myTypeOf result
85    where
86      myTypeOf :: forall a. ReadX a -> a
87      myTypeOf =  undefined
88
89  -- Handle an element
90  element = do c <- readX
91               case c of
92                 (CElem (Elem x as cs))
93                    |    as == [] -- no attributes
94                      && x  == (tyconUQname (dataTypeName (dataTypeOf myType)))
95                   -> alts cs
96                 _ -> mzero
97
98
99  -- A special case for lists
100  list :: forall a. Data a => ReadX [a]
101  list =          ( do h <- content2data
102                       t <- list
103                       return (h:t) )
104         `mplus`  return []
105
106  -- Fold over all alternatives, say constructors
107  alts cs = foldr (mplus . recurse cs) mzero shapes
108
109  -- Possible top-level shapes
110  shapes = map fromConstr consOf
111
112  -- Retrieve all constructors of the requested type
113  consOf = dataTypeConstrs
114         $ dataTypeOf
115         $ myType
116
117  -- Recurse into subterms
118  recurse cs x = maybe mzero
119                       return
120                       (runReadX (gmapM (const content2data) x) cs)
121
122  -- A special case for strings
123  string :: ReadX String
124  string =  do c <- readX
125               case c of
126                 (CString _ x) -> return x
127                 _             -> mzero
128
129  -- A special case for floats
130  float :: ReadX Float
131  float =  do c <- readX
132              case c of
133                (CString _ x) -> return (read x)
134                _             -> mzero
135
136
137
138-----------------------------------------------------------------------------
139--
140-- An XML-hungry parser-like monad
141--
142-----------------------------------------------------------------------------
143
144-- Type constructor
145newtype ReadX a =
146        ReadX { unReadX :: [Content]
147                        -> Maybe ([Content], a) }
148
149-- Run a computation
150runReadX x y = case unReadX x y of
151                 Just ([],y) -> Just y
152                 _           -> Nothing
153
154-- Read one content particle
155readX :: ReadX Content
156readX =  ReadX (\x -> if null x
157                        then Nothing
158                        else Just (tail x, head x)
159               )
160
161instance Functor ReadX where
162  fmap  = liftM
163
164instance Applicative ReadX where
165  pure  = return
166  (<*>) = ap
167
168instance Alternative ReadX where
169  (<|>) = mplus
170  empty = mzero
171
172-- ReadX is a monad!
173instance Monad ReadX where
174  return x = ReadX (\y -> Just (y,x))
175  c >>= f  = ReadX (\x -> case unReadX c x of
176                            Nothing -> Nothing
177                            Just (x', a) -> unReadX (f a) x'
178                   )
179
180-- ReadX also accommodates mzero and mplus!
181instance MonadPlus ReadX where
182  mzero = ReadX (const Nothing)
183  f `mplus` g = ReadX (\x -> case unReadX f x of
184                               Nothing -> unReadX g x
185                               y -> y
186                      )
187
188
189
190-----------------------------------------------------------------------------
191--
192--	Main function for testing
193--
194-----------------------------------------------------------------------------
195
196tests = (   genCom
197        , ( data2content genCom
198        , ( zigzag person1 :: Maybe Person
199        , ( zigzag genCom  :: Maybe Company
200        , ( zigzag genCom == Just genCom
201        ))))) ~=? output
202 where
203  -- Trealise back and forth
204  zigzag :: Data a => a -> Maybe a
205  zigzag = runReadX content2data . data2content
206
207output = (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))))
208