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
|
module Main where
import IO
import System (getArgs)
--import List (isPrefixOf)
import Text.XML.HaXml.Haskell2Xml
-- Test stuff
data MyType a = ConsA Int a
| ConsB String
{-! derive : Haskell2Xml !-}
instance Eq a => Eq (MyType a) where
(ConsA a b) == (ConsA c d) = a==c && b==d
(ConsB e) == (ConsB f) = e `isPrefixOf` f || f `isPrefixOf` e
_ == _ = False
{-
-- Hand-written example of preferred instance declaration.
instance Haskell2Xml a => Haskell2Xml (MyType a) where
toHType v = Defined "MyType" [toHType a]
[Constr "ConsA" [toHType a] [Prim "Int" "int", toHType a]
,Constr "ConsB" [] [String]
]
where (ConsA _ a) = v
toContents v@(ConsA n a) = [mkElemC (showConstr 0 (toHType v))
(concat [toContents n, toContents a])]
toContents v@(ConsB s) = [mkElemC (showConstr 1 (toHType v)) (toContents s)]
fromContents (CElem (Elem constr [] cs) : etc)
| "ConsA-" `isPrefixOf` constr =
(\(i,cs')-> (\(a,_) -> (ConsA i a,etc))
(fromContents cs')) (fromContents cs)
| "ConsB" `isPrefixOf` constr =
(\(s,_)-> (ConsB s, etc)) (fromContents cs)
-}
value1 :: Maybe ([(Bool,Int)],(String,Maybe Char))
value1 = Just ([(True,42),(False,0)],("Hello World",Nothing))
value2 :: (MyType [Int], MyType ())
value2 = (ConsA 2 [42,0], ConsB "hello world")
value3 :: MyType [Int]
value3 = ConsA 2 [42,0]
-- Main wrapper
main =
getArgs >>= \args->
if length args /= 3 then
putStrLn "Usage: <app> [1|2|3] [-w|-r] <xmlfile>"
else
let (arg0:arg1:arg2:_) = args in
( case arg1 of
"-w"-> return (stdout,WriteMode)
"-r"-> return (stdin,ReadMode)
_ -> fail ("Usage: <app> [-r|-w] <xmlfile>") ) >>= \(std,mode)->
( if arg2=="-" then return std
else openFile arg2 mode ) >>= \f->
( case arg0 of
"1" -> checkValue f mode value1
"2" -> checkValue f mode value2
"3" -> checkValue f mode value3
_ -> fail ("Usage: <app> [-r|-w] <xmlfile>") )
checkValue f mode value =
case mode of
WriteMode-> hWriteXml f value
ReadMode -> do ivalue <- hReadXml f
putStrLn (if ivalue==value then "success" else "failure")
-- WriteMode-> (hPutStrLn f . render . document . toXml) value1
-- ReadMode -> hGetContents f >>= \content ->
-- let ivalue = (fromXml . xmlParse) content in
-- (putStrLn . render . document . toXml) (ivalue `asTypeOf` value1) >>
-- putStrLn (if ivalue == value1 then "success" else "failure")
-- Machine generated stuff
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance (Haskell2Xml a) => Haskell2Xml (MyType a) where
toHType v =
Defined "MyType" [a]
[Constr "ConsA" [a] [toHType aa,toHType ab],
Constr "ConsB" [] [toHType ac]]
where
(ConsA aa ab) = v
(ConsB ac) = v
(a) = toHType ab
fromContents (CElem (Elem constr [] cs):etc)
| "ConsA" `isPrefixOf` constr =
(\(aa,cs00)-> (\(ab,_)-> (ConsA aa ab, etc)) (fromContents cs00))
(fromContents cs)
| "ConsB" `isPrefixOf` constr =
(\(ac,_)-> (ConsB ac, etc)) (fromContents cs)
fromContents (CElem (Elem constr _ _):etc) =
error ("expected ConsA or ConsB, got "++constr)
toContents v@(ConsA aa ab) =
[mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
toContents ab])]
toContents v@(ConsB ac) =
[mkElemC (showConstr 1 (toHType v)) (toContents ac)]
|
