{- |
  This module provides various utilities and short-cuts.
-}

module System.Terminal.Utility where

import Control.Exception (Exception (), throwIO)
import System.IO

import System.Terminal.Core

-- * Setting colours

-- | Set terminal foreground colour (background is set to black).
set_colour :: Colour -> IO ()
set_colour f = set_colours f DBlack

-- | Set default terminal colours (DWhite on DBlack).
set_colours_default :: IO ()
set_colours_default = set_colours DWhite DBlack

-- * Printing output

-- | Set terminal [foreground] colour and then 'putStrLn' a string.
putStrLnC :: Colour -> String -> IO ()
putStrLnC c t = do
  hFlush stdout
  set_colour c
  putStrLn t

{- |
  Write a pair of text strings on a single line, with different
  [foreground] text colours.
-}
putPairLn :: (Colour, String) -> (Colour, String) -> IO ()
putPairLn (c1, t1) (c2, t2) = do
  hFlush stdout
  set_colour c1
  putStr t1
  hFlush stdout
  set_colour c2
  putStrLn t2

{- |
  Print a single line of text, with a given character
  highlighted in colour. Useful for, say, highlighting the
  location of a syntax error in an expression.

  The tuple consists of three colour pairs. Each pair is
  a foreground\/background pair. The first pair applies to
  the next before the nominated position, the second pair
  applies to the nominated position itself, and the
  third pair applies to any text after the nominated
  position.

  The nominated position is given by the 'Int' argument,
  with 0 being the very first character of the string.
  Note that if the position is off the end of the
  string, a blank space will be added to the end of the
  string and /that/ will be highlighted.

  Note that no newline is written. If you want one, you
  must output it yourself.
-}
highlight :: ((Colour, Colour), (Colour, Colour), (Colour, Colour)) -> Int -> String -> IO ()
highlight ((f0, b0), (f1, b1), (f2, b2)) n msg = do
  if (n < 0) then error "System.Terminal.Utility.highlight: negative index" else return ()
  hFlush stdout
  set_colours f0 b0
  putStr (take n msg)
  hFlush stdout
  set_colours f1 b1
  if (n < length msg)
    then putChar (msg !! n)
    else putChar ' '
  hFlush stdout
  set_colours f2 b2
  putStr (drop (n+1) msg)

{- |
  A version of 'highlight' that outputs a newline after
  the final character of text.
-}
highlightLN :: ((Colour, Colour), (Colour, Colour), (Colour, Colour)) -> Int -> String -> IO ()
highlightLN cs n msg = do
  highlight cs n msg
  putChar '\n'

-- * Handling exceptions and errors

{- |
  A default top-level exception handler, for exceptions that
  fail to be caught before reaching the top level.

  In a properly designed application, exceptions should be
  anticipated, caught and handled in the correct place.
  (E.g., if you try to open a file, you should anticipate
  the possibility of an I\/O exception and catch\/process this
  appropriately.) Thus an exception reaching the top-level
  of the program would indicate a programming bug, and the
  generated error message reflects this. On a crash, the text

  > An internal program malfunction has occurred.
  > Please report this as a bug to the program developers.

  will be emitted on @stderr@, coloured bright yellow on a
  bright red background. The exception is then re-thrown
  (presumably halting the program).
-}
default_exception_handler :: Exception e => e -> IO x
default_exception_handler e = do
  hFlush stdout
  hFlush stderr
  set_colours LYellow LRed
  hPutStrLn stderr "!!!"
  hPutStrLn stderr ""
  hPutStrLn stderr "An internal program malfunction has occurred."
  hPutStrLn stderr "Please report this as a bug to the program developers."
  hPutStrLn stderr ""
  hFlush stderr
  set_colours_default
  throwIO e

{- |
  Take an 'IO' action, and run it with the
  'default_exception_handler' installed. Typically you would
  do something like

  > main = with_default_exception_handler main2
  >
  > main2 = do ...

  Now all unhandled exceptions in your program will cause a
  suitable message to be written to @stderr@.
-}
with_default_exception_handler :: IO x -> IO x
with_default_exception_handler act = catch act default_exception_handler