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
-- ----------------------------------------
|