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
|
{-# LANGUAGE BangPatterns#-}
-- ----------------------------------------
module Main(main)
where
import Text.XML.HXT.Core
import Text.Regex.XMLSchema.Generic
import Data.String.Unicode
( unicodeToXmlEntity
)
import Control.Monad.State.Strict hiding (when)
import Data.Maybe
import System.IO -- import the IO and commandline option stuff
import System.Environment
-- ----------------------------------------
main :: IO ()
main
= do
p <- getProgName
al <- getArgs
let i = if null al
then 4
else (read . head $ al)::Int
main' p i
where
main' p' = fromMaybe main1 . lookup (pn p') $ mpt
mpt = [ ("REtest", main1)
, ("Copy", main2 "copy" (:[]))
, ("Lines", main2 "lines" lines)
, ("RElines", main2 "relines" relines)
, ("Words", main2 "words" words)
, ("REwords", main2 "rewords" rewords)
]
-- ----------------------------------------
-- generate a document containing a binary tree of 2^i leafs (= 2^(i-1) XML elements)
main1 :: Int -> IO ()
main1 i
= runX (genDoc i (fn i))
>> return ()
-- ----------------------------------------
-- read a document containing a binary tree of 2^i leafs
main2 :: String -> (String -> [String]) -> Int -> IO ()
main2 ext lines' i
= do
hPutStrLn stderr "start processing"
h <- openBinaryFile (fn i) ReadMode
c <- hGetContents h
let ls = lines' c
o <- openBinaryFile (fn i ++ "." ++ ext) WriteMode
mapM_ (hPutStrLn o) ls
hClose o
hClose h
hPutStrLn stderr "end processing"
relines :: String -> [String]
relines = tokenize "[^\n\r]*"
rewords :: String -> [String]
rewords = tokenize "[^ \t\n\r]+"
-- ----------------------------------------
pn :: String -> String
pn = reverse . takeWhile (/= '/') . reverse
fn :: Int -> String
fn = ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show
-- ----------------------------------------
genDoc :: Int -> String -> IOSArrow b XmlTree
genDoc d out = constA (mkBTree d)
>>>
xpickleVal xpickle
>>>
indentDoc
>>>
putDoc out
-- ----------------------------------------
type Counter a = State Int a
incr :: Counter Int
incr = do
modify (+1)
get
-- ----------------------------------------
data BTree = Leaf Int
| Fork BTree BTree
deriving (Show)
instance XmlPickler BTree where
xpickle = xpAlt tag ps
where
tag (Leaf _ ) = 0
tag (Fork _ _ ) = 1
ps = [ xpWrap ( Leaf, \ (Leaf i) -> i)
( xpElem "leaf" $ xpAttr "value" $ xpickle )
, xpWrap ( uncurry Fork, \ (Fork l r) -> (l, r))
( xpElem "fork" $ xpPair xpickle xpickle )
]
-- ----------------------------------------
mkBTree :: Int -> BTree
mkBTree depth = evalState (mkT depth) 0
mkT :: Int -> Counter BTree
mkT 0 = do
i <- incr
return (Leaf i)
mkT n = do
l <- mkT (n-1)
r <- mkT (n-1)
return (Fork l r)
-- ----------------------------------------
-- output is done with low level ops to write the
-- document i a lazy manner
-- adding an xml pi and encoding is done "by hand"
-- latin1 decoding is the identity, so please generate the
-- docs with latin1 encoding. Here ist done even with ASCCI
-- every none ASCII char is represented by a char ref (&nnn;)
putDoc :: String -> IOStateArrow s XmlTree XmlTree
putDoc dst
= addXmlPi
>>>
addXmlPiEncoding isoLatin1
>>>
xshow getChildren
>>>
arr unicodeToXmlEntity
>>>
arrIO (\ s -> hPutDocument (\h -> hPutStrLn h s))
>>>
none
where
isStdout = null dst || dst == "-"
hPutDocument :: (Handle -> IO()) -> IO()
hPutDocument action
| isStdout
= action stdout
| otherwise
= do
handle <- openBinaryFile dst WriteMode
action handle
hClose handle
-- ----------------------------------------
|
