{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
 

 module Main where
 

 import System.IO
 import System.Process

 {-import System.Environment-}

 import System.Console.CmdArgs

 import System.Exit
 

 import Control.Concurrent
 
 import qualified Control.Exception as Exception
 import Control.Monad
 import Control.Monad.ST
 import Data.STRef
 
 import qualified UI.HSCurses.Curses as HSCurses
 import qualified UI.HSCurses.CursesHelper as HSCursesHelper
 

 mvWAddStr2 :: HSCurses.Window -> Int -> Int -> String -> IO ()

 mvWAddStr2 w y x s = do

   (rows, cols) <- HSCurses.scrSize
   when ((y >= 0) && (x >= 0) && (x < cols) && (y < rows)) $

       let space = cols - x

           s2 = take space s
        in
        HSCurses.mvWAddStr w y x s2

 -- This is currently a stub

 dispatch :: HSCurses.Key -> IO ()

 dispatch _ = return ()
 

 (--->) :: Monad m => (a -> m b) -> (a -> m c) -> a -> m c

 (--->) = liftM2 (>>)
 
 passTo :: a -> (a -> b) -> b
 passTo = flip ($)
 
 

 mainLoop :: Int -> Handle -> Int -> Bool -> IO ()

 mainLoop lim filein cols infinitep = stToIO (newSTRef 1) >>= loop

   where

     loop = discardResult . forever . wrapCode step HSCurses.refresh . stToIO . initialize

     initialize n = readSTRef n >>= (incSTRef n ---> addSTRefToTuple n)

     step (x,nextX) = discardResult $ do

       let handleInputp = filein /= stdin && not infinitep && ( nextX `mod` lim == 0)

       eofp <- atEnd
       if eofp then threadDelay 100
               else do
                 line <- hGetLine filein
                 x `passTo` (clearLine ---> showLine line ---> showDivider)
                 handleInput handleInputp

     clearLine x = moveAndAddString (getLinePos x) 0 $ replicate (cols+1) ' ' -- overwrite line
     showLine  line x = moveAndAddString (getLinePos x) 0 $ show x ++ (' ':line)   -- show new line
     showDivider x = moveAndAddString ( getLinePos (x+1) ) 0 div

     addSTRefToTuple n = flippedLiftM (readSTRef n) . (,)
     atEnd = hIsEOF filein
     discardResult = when True
     div = marker ++ replicate (cols - length marker + 1) '-'
     flippedLiftM = flip liftM
     getLinePos = subtract 1 . (`mod` lim)
     handleInput handleInputp = when handleInputp $ HSCurses.getCh >>= dispatch
     incSTRef n = writeSTRef n . (+ 1)
     marker = "--- break ---"
     moveAndAddString = mvWAddStr2 HSCurses.stdScr
     wrapCode run finalize init = (init >>= run) >> finalize

 
 allocate :: IO ()

 allocate = do
    HSCurses.initCurses
    hasColors <- HSCurses.hasColors

    when hasColors $ do
      HSCurses.startColor
      HSCurses.initPair
         (HSCurses.Pair 1)
         HSCursesHelper.black
         HSCursesHelper.white
 
 
 deallocate :: IO ()
 deallocate = HSCurses.endWin
 

 startTask :: String -> [FilePath] -> IO (Handle,Handle)
 startTask enc run = do

    let (runprog:myArgs) = run
    (_, Just hout, Just herr, _) <-
       createProcess (proc runprog myArgs) {
          std_out=CreatePipe,
          std_err=CreatePipe

       }
 
    -- enc <- mkTextEncoding "ISO-8859-1"

    encoding <- mkTextEncoding enc
    hSetEncoding hout encoding
    hSetEncoding herr encoding

    return (hout,herr)
 
 getStream :: String -> String -> [FilePath] -> IO Handle
 getStream stream enc run = do
   (hout,herr) <- startTask enc run
   return $ case stream of
     "stdout" -> hout
     _        -> herr

 
 work :: String -> [FilePath] -> Bool -> String -> IO ()
 work enc run infinitep stream = do
    (rows, cols) <- HSCurses.scrSize
    stream <- case run of
                [] -> return stdin
                _ -> getStream stream enc run
    mainLoop rows stream cols infinitep

    return ()
 
 
 data MyOptions = MyOptions {
    infinite :: Bool,
    run :: [String],

    encoding :: String,
    stream :: String

 } deriving (Data, Typeable, Show, Eq)
 
 myProgOpts :: MyOptions
 myProgOpts = MyOptions {
    infinite = def &= name "i",
    encoding = "UTF-8" &= name "e",

    stream = "stdout" &= name "s",

    run = def &= args
 }
 
 getOpts :: IO MyOptions

 getOpts = cmdArgs myProgOpts

 main :: IO ()

 main = do
    opts <- getOpts
    optionHandler opts
 
 optionHandler :: MyOptions -> IO ()

 optionHandler opts@MyOptions{..} = Exception.bracket_ allocate deallocate (work encoding run infinite stream)