#!/usr/local/bin/runhugs 
module Main(main) where 
import System(getArgs)
import IO(hClose,hPutStr,hGetContents,
	     stdin,stdout,openFile,IOMode,Handle,ReadMode,WriteMode)
toTexVer = "2Tex.3 Time-stamp: <1997-10-30 19:00:19 peter>"
{- 

   Simple program to read a half file on stdin and write 
   an tex representation on output.  If there is
   an argument, it is used for the title of the 
   file, else the string "stdin" is used.  The processing
   treats single line comments specially.  Comments may
   not be nested. 

   Stolen from a demo program in the hugs documentation.
   Note the first line! So one can use hugs like perl, or bash.
   The line is even acceptable to the Hugs interpreter!
-}


--   import System(getArgs)
--   import IO(hClose,hPutStr,hGetContents,
	--     stdin,stdout,openFile,IOMode,Handle,ReadMode,WriteMode)

main =    let fromHandle = stdin
	      toHandle = stdout 
	  in 
	  do args <- getArgs
	     let name = case args of { [] -> "stdin" ; a:args -> a }
	     -- do (name,fromHandle) <- getAndOpenFile "Copy from: " ReadMode
             -- (junk,toHandle)   <- getAndOpenFile "Copy to: " WriteMode
             contents   <- hGetContents fromHandle
             hPutStr toHandle (code_start name ++ code (\x->x) contents)
             hClose toHandle
--             putStr "Done."

   {- unused -}
getAndOpenFile          :: String -> IOMode -> IO (String,Handle)
getAndOpenFile prompt mode =
       do putStr prompt
          name <- getLine
          catch (do { h <- openFile name mode ; return (name,h) })
		(\_ -> do putStr ("Cannot open "++ name ++ "\n")
			  error "abandoned"
                          getAndOpenFile prompt mode)

code_start name = tex_header name 
code_end   =      tex_trailer
code_to_comm = "\""
comm_to_code = "\\verb\""

cb = " " -- "\\makebox[0ex]{\\{}-- "
ce = " " -- " \\makebox[0ex]{--}\\}"
oner_start = code_to_comm ++ "\\mbox{\\small\\textit{" ++ cb
oner_end = ce ++ "}}" ++ comm_to_code 

block_start =  code_to_comm ++ "\\par\n"
block_end = comm_to_code 

tex_header  name
          =  "\\documentclass{article}%-- " ++ toTexVer ++ "\n"
	  ++ "\\title{" ++ name ++ "}"
	  ++ "\\begin{document}\n"
	  ++ if (null name) then "" else "\\maketitle"
	  ++ comm_to_code

tex_trailer
	  =  code_to_comm
	  ++ "\n\\end{document}\n"   

{- the state machine -}

code b cs 
	= case cs of 
	       "" -> pcode (b cs) ++ code_end
	       [c] -> pcode (b cs) ++ code_end
	       ('{':'-':cs') -> pcode (b "") ++ comm (\x->x) cs'
	       (c1:c2:cs') -> code (b . (c1 :)) (c2:cs')

comm b cs 
	= case cs of
	        "" -> error "end of file in comment"
		[c] -> error "end of file in comment"
		('-':'}':cs') -> pcomm (b "") ++ code (\x->x) cs'
		(c1:c2:cs') -> comm (b . (c1 :)) (c2:cs' )

pcode str  = case str of 
	      "" -> ""
	      (c:cs) -> (if (c == '\n') 
			  then ((code_to_comm ++ "\\newline\n" ++comm_to_code)++)
			  else (c:)) (pcode cs)

pcode' str = if '\n' `elem` str 
		  then let ls = lines str
			   blank l = strip l == ""
			   paras ls = if (null ls) 
				        then []
					else let (bef,aft) = break blank ls
						 (jnk,aft') = break (not . blank) aft
				             in bef : paras aft' 
			   strip   = dropWhile (\c -> c ==' ' || c == '\t') 
			   indentation = length . takeWhile (\c -> c ==' ')
			   layp [] = code_to_comm ++ "\\newline\n" ++comm_to_code
			   layp (l:ls) = l ++
					 if (null ls) 
					   then ""
					   else code_to_comm
						++ "\\newline\n"
						++ comm_to_code
						++ layp ls 
			   layps   = layp -- concat . map (\p -> p++"\n") 
			   str' = layps (map layp (paras ls))
		       in str'
		  else str 
pcomm "" = ""
pcomm (c:str) = pcomm' (if c == '#' then "" else str)
pcomm' str = if '\n' `elem` str 
		  then let ls = lines str
			   blank l = strip l == ""
			   paras ls = if (null ls) 
				        then []
					else let (bef,aft) = break blank ls
						 (jnk,aft') = break (not . blank) aft
				             in bef : paras aft' 
			   strip   = dropWhile (\c -> c ==' ' || c == '\t') 
			   indentation = length . takeWhile (\c -> c ==' ')
			   layp    = concat . map (\l -> l++" \n")
			   layps   = concat . map (\p -> p++"\n<p>") 
			   str' = layps (map layp (paras ls))
		       in block_start ++ str ++ block_end
		  else oner_start ++ str ++ oner_end

	     
{- END -}

data Memory 
      = Leaf String | Fork (Char -> Memory)

contents :: (String -> String) -> Memory -> [(String,String)]
contents a t
      = case t of 
	  Leaf v -> [(a "",v)]
	  Fork phi -> concat [ contents (a . (c:)) (phi c) 
			     | c <- "abcdefghijklmnopqrstuvwxyz" ]

write addr val t 
      = case addr of 
         "" -> Leaf val
	 (c:cs) -> 
	       case t of 
	    	   Leaf str -> write addr val (Fork ( \c -> t ))
		   Fork phi -> let t' = write cs val (phi c) 
			       in  Fork (\ c' -> if c == c' then t' else phi c' )

{- experiments -}

reada b addr t 
     = case t of 
        Leaf val -> (b "",val)	-- return address used
	Fork phi -> case addr of 
		      "" -> reada b " " t 
		      (c:cs)  ->  reada (b . (c:)) cs (phi c) 
			      
tree = (foldr (\(addr,val) t -> write addr val t) (Leaf "")  . reverse )
        [("foo","bar"),("ab","ba"),("a","a"),("b","b"),("ab","ba")]     

prefix "" str = 0 == 0
prefix (c:cs) "" = 0 == 1
prefix (c:cs) (d:ds) = if (c == d) then prefix cs ds else 0 == 2

blank l = let (n,rest) = indent l in rest == ""

eat = eat' . map indent . filter (not . blank)
eat' [] = []
-- eat' ((i,l):ls) = let e = (i:l)

indent line
  = indent' 0 line
    where indent' n (' ':cs) = indent' (n+1) cs
	  indent' n ('\t':cs) = indent' (8*(1+n/8)) cs
	  indent' n str = (n,str)

{- return the pieces of a string, where str is the separator -}
pieces :: String -> String -> [ String ]
pieces sep str
       = case sep of 
          "" -> let x = "":x in x
	  (c:_) 
	     -> pieces1 str (\x->x)
                where
	         pieces1 str b 
		   = case str of 
		      "" -> [b ""]
		      _  ->  let (bef,aft) = break (c ==) str
			     in 
			     case aft of 
			      "" -> [b bef]
			      _:aft' 
			         -> if sep `prefix` aft
			     	    then let str' = drop (length sep) aft
					 in (b bef: pieces1 str' (\x->x))
			            else pieces1 aft' (b . (bef++) . (c:))

mybreak p str 
	= mybreak1 str (\x -> x)
	  where 
	    mybreak1 str b 
	            = case str of 
		     	   "" -> [b ""]
			   (c:cs) -> if p c then (b "":mybreak1 cs (\x->x))
					    else mybreak1 cs (b . (c:))
sb p 
  = sb1 (\x->x)
    where sb1 b str 
	      = if (p str) then [(b "",str)]
			   else case str of 
				     "" -> []
				     (c:cs) -> sb1 (b . (c:)) cs
{- experiments 
   upto c ""      = ("","")
   upto c 
	(ch:str)  = upto1 c (ch:) str
	            where upto1 c b "" = (b "","")
			  upto1 c b (ch:str') 
				= if (c == ch) 
				     then ( b "", str )
				     else upto1 c (b . (ch:)) str'

   seq' p q str = let { (a,str') = p str ; (b,str'') = q str' } in (a++b,str'')


   empty "" = 0 == 0
   empty (c:cs) = 0 == 1

   upto' "" str = ""
   upto' (c:cs) "" = ""
   upto' (c:cs) (d:ds) = if c == d then if prefix cs ds then ""
							else d:upto' (c:cs) ds
				   else d : upto' (c:cs) ds
  
   un a = \s -> (a,s)
   bi p f = \s-> let { (a,s') = p s } in f a s'

{-\
   script = cd `bi` \cod -> 
	    rep (co `bi` \ com ->
		 cd `bi` \ cod -> 
		 un (comm++fs) )
	       `bi` \rest ->
	    un (cod++rest) 
		   
   cd = \ str -> 
	let  x = upto "{-" str 
	     str' = drop (length x) str 
	in (x,str') 
   co = \str ->
        let  y = upto "-}" str
	     str' = dtrop (length y) str
	in (y,str') 
   rep p = \str -> 
	   case str of 
	    "" -> ("","")
	    (c:cs) -> 

-}	

-}