{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -F -pgmF htfpp #-}

module DPM.Core.Utils (

  listReplaceAt, listDeleteAt, readM, execCommand, findCommand,
  escapeRegexChars, escapeRegexChar, unlessM, whenM,
  retain, trim, bool, formatTime, formatTimeUTC,
  darcsDateFormat, darcsInternDateFormat, prettyDate,
  joinStrings, splitOn,

  allHTFTests

) where

import Test.Framework
import System.Cmd ( rawSystem )
import System.Exit
import Control.Monad
import qualified Data.List as List
import Data.Char ( isSpace )
import System.Directory ( doesFileExist, doesDirectoryExist )
import System.FilePath
import Text.PrettyPrint
import Data.Time ( UTCTime, TimeZone, getCurrentTimeZone,
                    utcToLocalTime )
import qualified Data.Time
import System.Locale ( defaultTimeLocale )
import System.IO.Unsafe ( unsafePerformIO )

listReplaceAt :: Int -> a -> [a] -> [a]
listReplaceAt i x l
    | i < 0  = error "listReplaceAt: index too small"
    | i == 0 =
        case l of
          []   -> error "listReplaceAt: index too small"
          _:ys -> x : ys
    | otherwise =
        case l of
          []   -> error "DPM.Utils.listReplaceAt: index too large"
          y:ys -> y : listReplaceAt (i-1) x ys

prop_listReplaceAt :: Char -> [Char] -> Property
prop_listReplaceAt new l =
    not (null l) ==>
    forAll (choose (0, max 0 (length l - 1))) $ \ix ->
      let l' = listReplaceAt ix new l
      in (l' !! ix == new) &&
         (and [l!!i == l'!!i | i <- [0..(length l - 1)], i /= ix])

listDeleteAt :: Int -> [a] -> [a]
listDeleteAt i [] = error ("DPM.Utils.listDeleteAt: list empty")
listDeleteAt i (x:xs)
    | i < 0     = error ("DPM.Utils.listDeleteAt: index too small")
    | i == 0    = xs
    | otherwise = x : listDeleteAt (i-1) xs

prop_listDeleteAt :: [Char] -> Property
prop_listDeleteAt l =
    not (null l) ==>
    forAll (choose (0, max 0 (length l - 1))) $ \ix ->
      let l' = listDeleteAt ix l
      in (and [l!!i == l'!!i | i <- [0..(ix - 1)]]) &&
         (and [l!!(i+1) == l'!!i | i <- [ix..(length l -2)]])

readM :: (Monad m, Read a) => String -> m a
readM s | [x] <- parse = return x
        | otherwise    = fail $ "Failed parse: " ++ show s
    where
      parse = [x | (x,t) <- reads s]

execCommand :: FilePath -> [String] -> IO (Either String ())
execCommand cmd args =
    do retcode <- rawSystem cmd args
       case retcode of
         ExitSuccess -> return (Right ())
         ExitFailure i ->
             return (Left ("Command " ++ show cmd ++ " with arguments " ++
                           show args ++ " failed with exit code " ++ show i))

findCommand :: FilePath -> IO (Either String FilePath)
findCommand fname =
    if pathSeparator `elem` fname
       then return (Right fname)
       else do path <- getSearchPath
               l <- filterM doesFileExist $ map (\p -> p </> fname) path
               case l of
                 [] -> return $ Left ("No executable " ++ show fname ++
                                      " found")
                 x:_ -> return (Right x)

escapeRegexChars :: String -> String
escapeRegexChars = concatMap escapeRegexChar

-- copied from the Real World Haskell book
escapeRegexChar :: Char -> String
escapeRegexChar c | c `elem` regexChars = '\\' : [c]
         | otherwise = [c]
    where regexChars = "\\+()^$.{}]|"

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM cond act =
    do b <- cond
       unless b act

whenM :: Monad m => m Bool -> m () -> m ()
whenM cond act =
    do b <- cond
       when b act

retain :: Int -> [a] -> [a]
retain i l =
    let n = length l
    in drop (n - i) l

prop_retainEmpty :: [Int] -> Bool
prop_retainEmpty l = null $ retain 0 l

prop_retainFull :: [Int] -> Bool
prop_retainFull l = l == retain (length l) l

prop_retainLength :: Int -> [Int] -> Bool
prop_retainLength i l = length (retain i l) == max 0 (min i (length l))

prop_retainSuffix :: Int -> [Int] -> Bool
prop_retainSuffix i l = List.isSuffixOf (retain i l) l

trim :: String -> String
trim = f . f
   where f = reverse . dropWhile isSpace

bool :: Bool -> Doc
bool True = text "yes"
bool False = text "no"

timeZone :: TimeZone
timeZone = unsafePerformIO getCurrentTimeZone

formatTimeUTC :: String -> UTCTime -> String
formatTimeUTC format time =
    Data.Time.formatTime defaultTimeLocale format time

formatTime :: String -> UTCTime -> String
formatTime format time =
    let local = utcToLocalTime timeZone time
    in Data.Time.formatTime defaultTimeLocale format local

darcsDateFormat :: String
darcsDateFormat = "%a %b %e %T %Z %Y"

darcsInternDateFormat :: String
darcsInternDateFormat = "%Y%m%d%H%M%S"

prettyDate :: UTCTime -> String
prettyDate date =
    formatTime darcsDateFormat date

joinStrings :: [String] -> String
joinStrings = List.intercalate " "

splitOn :: (a -> Bool) -> [a] -> [[a]]
splitOn _ [] = []
splitOn f l@(x:xs)
  | f x = splitOn f xs
  | otherwise = let (h,t) = break f l in h:(splitOn f t)