content: {-# LANGUAGE BangPatterns#-}
  {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
  
  -- ----------------------------------------
  
  module Main
  where
  
  import Text.XML.HXT.Core
  -- import Text.XML.HXT.TagSoup
  -- import Text.XML.HXT.Expat
  
  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
        (is : _) <- getArgs
        let i = (read is)::Int
        main' p i
      where
      main' p' = fromMaybe main0 . lookup (pn p') $ mpt
      mpt = [ ("GenDoc",	   main1)
  	  , ("ReadDoc",    main2)
  	  , ("PruneRight", main3 False)
  	  , ("PruneLeft",  main3 True)
  	  , ("MemTest",    main4)
  	 ]
  
  -- ----------------------------------------
  
  -- 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	:: Int -> IO ()
  main2 i
      = do
        [x] <- runX (readDoc (fn i)
  		   >>>
  		   traceMsg 1 "start unpickle"
  		   >>>
  		   unpickleTree
  		   >>>
  		   traceMsg 1 "start fold"
  		   >>>
  		   arr (foldT1 max)
  		  )
        putStrLn ( "maximum value in tree is " ++ show x ++
  		 ", expected value was " ++ show ((2::Int)^i)
  	       )
  
  -- ----------------------------------------
  
  -- test on lazyness, is the whole tree read or only the first child of every child node?
  
  main3	:: Bool -> Int -> IO ()
  main3 l i
      = do
        [t] <- runX ( readDoc (fn i)
  		    >>>
  		    fromLA (xshow ( getChildren
  				    >>>
  				    if l then pruneForkLeft else pruneForkRight
  				  )
  			   )
  		  )
        putStrLn ("pruned binary tree is : " ++ show t)
  
  -- ----------------------------------------
  
  main4	:: Int -> IO ()
  main4 i
      = do
        [x] <- runX ( setTraceLevel 1
  		    >>>
  		    traceMsg 1 ("generate tree of depth " ++ show i)
  		    >>>
  		    fromLA (genTree 0 i)
  		    >>>
  		    traceMsg 1 ("compute maximum and minimum")
  		    >>>
  		    fromLA ( foldBTree maximum &&& foldBTree minimum )	-- 2 traversals: complete tree in mem
  		    >>>
  		    arr2 (\ ma mi -> "maximum value = " ++ show ma ++ ", minimum = " ++ show mi )
  		    >>>
  		    traceValue 1 id
  		  )
        putStrLn x
  
  foldBTree	:: ([Int] -> Int) -> LA XmlTree Int
  foldBTree f
      = choiceA
        [ hasName "leaf" :-> ( getAttrValue "value" >>^ read )
        , hasName "fork" :-> ( (getChildren >>> foldBTree f) >. f )
        , this           :-> none
        ]
  
  -- ----------------------------------------
  
  -- just to check how much memory is used for the tree
  
  main0	:: Int -> IO ()
  main0 i
      = do
        let t = mkBTree i
        let m = show . foldT1 max $ t
        putStrLn ("maximum value in tree is " ++ m ++ ", minimum value is " ++ show (foldT1 min t))
        return ()
  
  -- ----------------------------------------
  
  pn	:: String -> String
  pn	= reverse . takeWhile (/= '/') . reverse
  
  fn	:: Int -> String
  fn	= ("tree-" ++) . (++ ".xml") . reverse . take 4 . reverse . ((replicate 4 '0') ++ ) . show
  
  -- ----------------------------------------
  
  genTree	:: Int -> Int -> LA XmlTree XmlTree
  genTree !n !d
      | d == 0	= aelem "leaf" [sattr "value" (show (n + 1))]
      | otherwise	= selem "fork" [ genTree (2*n)   (d-1)
  			       , genTree (2*n+1) (d-1)
  			       ]
  
  -- ----------------------------------------
  
  genDoc		:: Int -> String -> IOSArrow b XmlTree
  genDoc d out    = constA (mkBTree d)
  		  >>>
  		  xpickleVal xpickle
                    >>>
                    strictA
                    >>>
                    writeBinaryValue (out ++ ".bin")
                    >>>
                    readBinaryValue (out ++ ".bin")
  		  >>>
  		  putDoc out
  
  -- ----------------------------------------
  
  readDoc	:: String -> IOSArrow b XmlTree
  readDoc src
      = readDocument [ withParseHTML no
  		   -- , withRemoveWS yes
  		   , withInputEncoding isoLatin1
  		   , withWarnings no
  		   , withTrace 1
  		   , withStrictInput no
  		   -- , withRemoveWS yes
                     -- , withExpat yes
                     -- , withTagSoup
  		   ] src
        >>>
        processChildren (isElem `guards` this)
  
  -- ----------------------------------------
  
  unpickleTree	:: ArrowXml a => a XmlTree BTree
  unpickleTree	= xunpickleVal xpickle
  
  -- ----------------------------------------
  
  pruneForkRight	:: LA XmlTree XmlTree
  pruneForkRight
      = ( replaceChildren
  	( ( getChildren >>. take 1 )
  	  >>>
  	  pruneForkRight
  	)
        ) `when` (hasName "fork")
  
  
  pruneForkLeft	:: LA XmlTree XmlTree
  pruneForkLeft
      = ( replaceChildren
  	( ( getChildren >>. drop 1 )
  	  >>>
  	  pruneForkLeft
  	)
        ) `when` (hasName "fork")
  
  -- ----------------------------------------
  
  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)
  
  -- ----------------------------------------
  
  foldT1	:: (Int -> Int -> Int) -> BTree -> Int
  foldT1 _  (Leaf v)	= v
  foldT1 op (Fork l r)	= foldT1 op l `op` foldT1 op 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
  
  -- ----------------------------------------
  