{-# 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)