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