content: {-# 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
  
  -- ----------------------------------------
  