Feedback.hs

{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Code to facilitate giving feedback
--
-----------------------------------------------------------------------------

module WinDll.Utils.Feedback where

#ifdef DEBUG
import WinDll.Session.Debug
#else
import WinDll.Session.Hs2lib
#endif

import Control.Monad.State

import System.IO.Unsafe
import System.Exit
import System.Directory

import Data.Function
import Text.Printf

-- | debug function that prints out de given message only if the specified debug level
-- is atleast that which was specified by the commandline options to the program
-- 
-- The debug levels are:
-- 0    - Off
-- 1    - Informational
-- 2    - Detailed informational
inform :: Int -> String -> Exec ()
inform level msg = 
 do session <- get
    let dbg = verbosity session
    liftIO $ when (level <= dbg && dbg /= 0) $ putStrLn ("*** " ++ msg)

-- | Print out a progress bar. This prints and updates a progressbar in ASCII format.
--   The arguments are as follows:
--   debug level - When to print the progress
--   current     - The current count of the progress
--   total       - The total number of items being processed
--   width       - Total amount of stars to render
progress :: Int -> Int -> Int -> Int -> Exec ()
progress level current total width 
  = do session <- get
       let perc  = ((/) `on` fromIntegral) current total :: Float
           stars = round $ perc * (fromIntegral width)
           bars  = width - stars
           dbg   = verbosity session
       liftIO $ when (level <= dbg) $ putStr $ "\r*** Analyzing [" ++ replicate stars '*' ++ replicate bars '-' ++ "] " ++ printf "%.2f" (perc * 100) ++ "%"
    
-- | Normal Information message
_normal = 1 :: Int

-- | Detauled Information message
_detail = 2 :: Int

-- | Always print this message
_always = 0 :: Int

-- | Always print
echo :: String -> Exec ()
echo = liftIO . putStrLn . ("*** "++)

-- | Give the user a warning and exits if warnings are treated like errors
warn :: String -> Exec ()
warn msg = 
 do session <- get 
#ifdef DEBUG
    let werr = False
    let warnings_enabled = True
#else
    let werr = warnings_as_errors session
    let warnings_enabled = warnings session
#endif
    liftIO $ when (warnings_enabled && not werr) $ putStrLn ("Warning: " ++ msg)
    if werr then die msg
            else return ()
            
-- | Give the user a Error and exit
die :: String -> Exec a
die msg = (liftIO $ putStrLn ("Error: " ++ msg)) >> cleanup >> liftIO exitFailure
        
-- | Cleanup any temporary files we might have written, if the value keep_temps has not been set.
cleanup :: Exec ()
cleanup = 
 do inform _normal "Cleaning up...."
    session <- get
#ifndef DEBUG
    let build  = pipeline session
        dir    = dirPath build
    case keep_temps session || null (files build) of
        True  -> inform _detail "Nothing to clean up."
              >> when (keep_temps session) (liftIO $ putStrLn $ "Preserved " ++ dir)
        False -> mapM_ (\a->inform _detail ("Cleaning '" ++ a ++ "'...") >> liftIO (removeFile (dir++a))) (files build)
              >> inform _detail ("Removing " ++ dir ++ "...")
              >> liftIO (removeDirectoryRecursive dir)
#endif    
    inform _detail "Cleanup done..."