Blame examples/RegexXMLSchema/REtest.hs

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