File: REtest.hs

package info (click to toggle)
haskell-hxt-regex-xmlschema 9.2.0.7-3
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 268 kB
  • sloc: haskell: 3,182; makefile: 216
file content (170 lines) | stat: -rw-r--r-- 3,916 bytes parent folder | download | duplicates (5)
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

-- ----------------------------------------