{-# LANGUAGE CPP #-}
{- |
Module      :  ./Common/Utils.hs
Description :  utility functions that can't be found in the libraries
Copyright   :  (c) Klaus Luettich, Uni Bremen 2002-2006
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

Utility functions that can't be found in the libraries
               but should be shared across Hets.
-}

module Common.Utils
  ( isSingleton
  , replace
  , hasMany
  , number
  , combine
  , trim
  , trimLeft
  , trimRight
  , toSnakeCase
  , nubOrd
  , nubOrdOn
  , atMaybe
  , readMaybe
  , mapAccumLM
  , mapAccumLCM
  , concatMapM
  , composeMap
  , keepMins
  , splitOn
  , splitPaths
  , splitBy
  , splitByList
  , numberSuffix
  , basename
  , dirname
  , fileparse
  , stripDir
  , stripSuffix
  , makeRelativeDesc
  , getEnvSave
  , getEnvDef
  , filterMapWithList
  , timeoutSecs
  , executeProcess
  , executeProcessWithEnvironment
  , timeoutCommand
  , withinDirectory
  , writeTempFile
  , getTempFile
  , getTempFifo
  , readFifo
  , tryToStripPrefix  
  , verbMsg
  , verbMsgLn
  , verbMsgIO
  , verbMsgIOLn
  ) where

import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set

import System.Directory
import System.Environment
import System.Exit
import System.FilePath (joinPath, makeRelative, equalFilePath, takeDirectory)
import System.IO
import System.IO.Error (isEOFError)
import System.Process
import System.Timeout
#ifdef UNIX
import System.Posix.Files (createNamedPipe, unionFileModes,
                           ownerReadMode, ownerWriteMode)
import System.Posix.IO (OpenMode (ReadWrite), defaultFileFlags,
                        openFd, closeFd, fdRead)

import Control.Concurrent (threadDelay, forkIO, killThread)
import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
import Control.Exception as Exception

import System.IO.Unsafe (unsafeInterleaveIO)
#endif

import Control.Monad

{- | Writes the message to the given handle unless the verbosity is less than
the message level. -}
verbMsg :: Handle -- ^ Output handle
        -> Int -- ^ global verbosity
        -> Int -- ^ message level
        -> String -- ^ message level
        -> IO ()
verbMsg hdl v lvl = when (lvl <= v) . hPutStr hdl

-- | Same as 'verbMsg' but with a newline at the end
verbMsgLn :: Handle -> Int -> Int -> String -> IO ()
verbMsgLn hdl v lvl = when (lvl <= v) . hPutStrLn hdl

-- | 'verbMsg' with stdout as handle
verbMsgIO :: Int -> Int -> String -> IO ()
verbMsgIO = verbMsg stdout

-- | 'verbMsgLn' with stdout as handle
verbMsgIOLn :: Int -> Int -> String -> IO ()
verbMsgIOLn = verbMsgLn stdout

{- | replace all occurrences of the first (non-empty sublist) argument
     with the second argument in the third (list) argument. -}
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace sl r = case sl of
  [] -> error "Common.Utils.replace: empty list"
  _ -> concat . unfoldr (\ l -> case l of
    [] -> Nothing
    hd : tl -> Just $ case stripPrefix sl l of
      Nothing -> ([hd], tl)
      Just rt -> (r, rt))

-- | add indices to a list starting from one
number :: [a] -> [(a, Int)]
number = flip zip [1 ..]

-- | /O(1)/ test if the set's size is one
isSingleton :: Set.Set a -> Bool
isSingleton s = Set.size s == 1

-- | /O(1)/ test if the set's size is greater one
hasMany :: Set.Set a -> Bool
hasMany s = Set.size s > 1

{- | Transform a list @[l1, l2, ... ln]@ to (in sloppy notation)
     @[[x1, x2, ... xn] | x1 <- l1, x2 <- l2, ... xn <- ln]@
     (this is just the 'sequence' function!) -}
combine :: [[a]] -> [[a]]
combine = sequence
-- see http://www.haskell.org/pipermail/haskell-cafe/2009-November/069490.html

-- | trims a string both on left and right hand side
trim :: String -> String
trim = trimRight . trimLeft

-- | trims a string only on the left side
trimLeft :: String -> String
trimLeft = dropWhile isSpace

-- | trims a string only on the right side
trimRight :: String -> String
trimRight = foldr (\ c cs -> if isSpace c && null cs then [] else c : cs) ""

{-
   Convert CamelCased or mixedCases 'String' to a 'String' with underscores,
   the \"snake\" 'String'.

   It also considers SCREAMINGCamelCase:
   `toSnakeCase "SomeSCREAMINGCamelCase" == "some_screaming_camel_case"`
-}
toSnakeCase :: String -> String
toSnakeCase c = if hasBump c then unScream c else mkSnake c where
  hasBump s = case s of
    a : b : _ -> isUpper a && isLower b
    _ -> False
  unScream s = case s of
    a : r -> toLower a : mkSnake r
    _ -> s
  mkSnake s = let newSnake t = '_' : unScream t in case s of
    a : r@(b : _) | hasBump [b, a] -> a : newSnake r
    _ | hasBump s -> newSnake s
    _ -> unScream s

-- | strip a prefix from a string, if possible
tryToStripPrefix :: String -> String -> String
tryToStripPrefix prefix s = fromMaybe s $ stripPrefix prefix s
  
{- | The 'nubWith' function accepts as an argument a \"stop list\" update
function and an initial stop list. The stop list is a set of list elements
that 'nubWith' uses as a filter to remove duplicate elements.  The stop list
is normally initially empty.  The stop list update function is given a list
element a and the current stop list b, and returns 'Nothing' if the element is
already in the stop list, else 'Just' b', where b' is a new stop list updated
to contain a. -}
nubWith :: (a -> b -> Maybe b) -> b -> [a] -> [a]
nubWith f s es = case es of
  [] -> []
  e : rs -> case f e s of
       Just s' -> e : nubWith f s' rs
       Nothing -> nubWith f s rs

nubOrd :: Ord a => [a] -> [a]
nubOrd = nubOrdOn id

nubOrdOn :: Ord b => (a -> b) -> [a] -> [a]
nubOrdOn g = let f a s = let e = g a in
                   if Set.member e s then Nothing else Just (Set.insert e s)
  in nubWith f Set.empty

-- | safe variant of !!
atMaybe :: [a] -> Int -> Maybe a
atMaybe l i = if i < 0 then Nothing else case l of
  [] -> Nothing
  x : r -> if i == 0 then Just x else atMaybe r (i - 1)

readMaybe :: Read a => String -> Maybe a
readMaybe s = case filter (all isSpace . snd) $ reads s of
  [(a, _)] -> Just a
  _ -> Nothing

-- | generalization of mapAccumL to monads
mapAccumLM :: Monad m
  => (acc -> x -> m (acc, y))
    {- ^ Function taking accumulator and list element,
         returning new accumulator and modified list element -}
  -> acc           -- ^ Initial accumulator
  -> [x]           -- ^ Input list
  -> m (acc, [y])  -- ^ Final accumulator and result list
mapAccumLM f s l = case l of
  [] -> return (s, [])
  x : xs -> do
    (s', y) <- f s x
    (s'', ys) <- mapAccumLM f s' xs
    return (s'', y : ys)

-- | generalization of mapAccumL to monads with combine function
mapAccumLCM :: (Monad m) => (a -> b -> c) -> (acc -> a -> m (acc, b))
          -> acc -> [a] -> m (acc, [c])
mapAccumLCM g f s l = case l of
  [] -> return (s, [])
  x : xs -> do
    (s', y) <- f s x
    (s'', ys) <- mapAccumLCM g f s' xs
    return (s'', g x y : ys)

{- | Monadic version of concatMap
     taken from http://darcs.haskell.org/ghc/compiler/utils/MonadUtils.hs -}
concatMapM :: (Traversable t, Monad m) => (a -> m [b]) -> t a -> m [b]
concatMapM f = liftM concat . mapM f

-- | composition of arbitrary maps
composeMap :: Ord a => Map.Map a b -> Map.Map a a -> Map.Map a a -> Map.Map a a
composeMap s m1 m2 = if Map.null m2 then m1 else Map.intersection
  (Map.foldWithKey ( \ i j ->
    let k = Map.findWithDefault j j m2 in
    if i == k then Map.delete i else Map.insert i k) m2 m1) s

-- | keep only minimal elements
keepMins :: (a -> a -> Bool) -> [a] -> [a]
keepMins lt l = case l of
    [] -> []
    x : r -> let s = filter (not . lt x) r
                 m = keepMins lt s
              in if any (`lt` x) s then m
                 else x : m

{- |
  A function inspired by the perl function split. A list is splitted
  on a separator element in smaller non-empty lists.
  The separator element is dropped from the resulting list.
-}
splitOn :: Eq a => a -- ^ separator
        -> [a] -- ^ list to split
        -> [[a]]
splitOn x = filter (not . null) . splitBy x

-- | split a colon (or on windows semicolon) separated list of paths
splitPaths :: String -> [FilePath]
splitPaths = splitOn
#ifdef UNIX
            ':'
#else
            ';'
#endif

{- |
  Same as splitOn but empty lists are kept. Even the empty list is split into
  a singleton list containing the empty list.
-}
splitBy :: Eq a => a -- ^ separator
        -> [a] -- ^ list to split
        -> [[a]]
splitBy c l = let (p, q) = break (c ==) l in p : case q of
     [] -> []
     _ : r -> splitBy c r

{- | Same as splitBy but the separator is a sublist not only one element.
Note that the separator must be non-empty. -}
splitByList :: Eq a => [a] -> [a] -> [[a]]
splitByList sep l = case l of
    [] -> [[]]
    h : t -> case stripPrefix sep l of
      Just suf -> [] : splitByList sep suf
      Nothing -> let f : r = splitByList sep t in (h : f) : r

{- | If the given string is terminated by a decimal number
this number and the nonnumber prefix is returned. -}
numberSuffix :: String -> Maybe (String, Int)
numberSuffix s =
    let f a r@(x, y, b) =
            let b' = isDigit a
                y' = y + x * digitToInt a
                out | not b = r
                    | b && b' = (x * 10, y', b')
                    | otherwise = (x, y, False)
            in out
    in case foldr f (1, 0, True) s of
         (1, _, _) ->
             Nothing
         (p, n, _) ->
             Just (take (1 + length s - length (show p)) s, n)

{- |
  A function inspired by a perl function from the standard perl-module
  File::Basename. It removes the directory part of a filepath.
-}
basename :: FilePath -> FilePath
basename = snd . stripDir

{- |
  A function inspired by a perl function from the standard perl-module
  File::Basename. It gives the directory part of a filepath.
-}
dirname :: FilePath -> FilePath
dirname = fst . stripDir

{- |
  A function inspired by a perl function from the standard perl-module
  File::Basename. It splits a filepath into the basename, the
  directory and gives the suffix that matched from the list of
  suffixes. If a suffix matched it is removed from the basename.
-}
fileparse :: [String] -- ^ list of suffixes
          -> FilePath
          -> (FilePath, FilePath, Maybe String)
          -- ^ (basename,directory,matched suffix)
fileparse sufs fp = let (path, base) = stripDir fp
                        (base', suf) = stripSuffix sufs base
                    in (base', path, suf)

stripDir :: FilePath -> (FilePath, FilePath)
stripDir =
    (\ (x, y) -> (if null y then "./" else reverse y, reverse x))
    . break (== '/') . reverse

stripSuffix :: [String] -> FilePath -> (FilePath, Maybe String)
stripSuffix suf fp = case filter isJust $ map (stripSuf fp) suf of
                       Just (x, s) : _ -> (x, Just s)
                       _ -> (fp, Nothing)
    where stripSuf f s | s `isSuffixOf` f =
                           Just (take (length f - length s) f, s)
                       | otherwise = Nothing


{- |
  This function generalizes makeRelative in that it computes also a relative
  path with descents such as ../../test.txt
-}
makeRelativeDesc :: FilePath -- ^ path to a directory
                 -> FilePath -- ^ to be computed relatively to given directory
                 -> FilePath -- ^ resulting relative path
makeRelativeDesc dp fp = f dp fp []
    where f "" y l = joinPath $ l ++ [y]
          f x y l = let y' = makeRelative x y
                    in if equalFilePath y y'
                       then f (takeDirectory x) y $ ".." : l
                       else joinPath $ l ++ [y']

{- | filter a map according to a given list of keys (it dosen't hurt
   if a key is not present in the map) -}
filterMapWithList :: Ord k => [k] -> Map.Map k e -> Map.Map k e
filterMapWithList = filterMapWithSet . Set.fromList

{- | filter a map according to a given set of keys (it dosen't hurt if
   a key is not present in the map) -}
filterMapWithSet :: Ord k => Set.Set k -> Map.Map k e -> Map.Map k e
filterMapWithSet s = Map.filterWithKey (\ k _ -> Set.member k s)

{- | get, parse and check an environment variable; provide the default
  value, only if the envionment variable is not set or the
  parse-check-function returns Nothing -}
getEnvSave :: a                   -- ^ default value
           -> String              -- ^ name of environment variable
           -> (String -> Maybe a) -- ^ parse and check value of variable
           -> IO a
getEnvSave defValue envVar readFun =
    liftM (maybe defValue (fromMaybe defValue . readFun)
           . lookup envVar) getEnvironment

-- | get environment variable
getEnvDef :: String -- ^ environment variable
          -> String -- ^  default value
          -> IO String
getEnvDef envVar defValue = getEnvSave defValue envVar Just

-- | the timeout function taking seconds instead of microseconds
timeoutSecs :: Int -> IO a -> IO (Maybe a)
timeoutSecs time = timeout $ let
  m = 1000000
  u = div maxBound m
  in if time > u then maxBound else
     if time < 1 then 100000 -- 1/10 of a second
     else m * time


-- | like readProcessWithExitCode, but checks the command argument first
executeProcess
    :: FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
    -> String                   -- ^ standard input
    -> IO (ExitCode, String, String) -- ^ exitcode, stdout, stderr
executeProcess cmd args input = do
  mp <- findExecutable cmd
  case mp of
    Nothing -> return (ExitFailure 127, "", "command not found: " ++ cmd)
    Just exe -> readProcessWithExitCode exe args input

executeProcessWithEnvironment :: FilePath
                              -> [String]
                              -> String
                              -> [(String, String)]
                              -> IO (ExitCode, String, String)
executeProcessWithEnvironment cmd args input environment = do
  mp <- findExecutable cmd
  case mp of
    Nothing -> return (ExitFailure 127, "", "command not found: " ++ cmd)
    Just exe -> do
      (Just hin, mHout, mHerr, processHandle) <-
        createProcess $ (proc exe args) { env = Just environment
                                        , std_in = CreatePipe
                                        , std_out = CreatePipe
                                        }
      hPutStr hin input
      out <- case mHout of
        Just hout -> hGetContents hout
        _ -> return ""
      err <- case mHerr of
        Just herr -> hGetContents herr
        _ -> return ""
      exitCode <- waitForProcess processHandle
      return (exitCode, out, err)

-- | runs a command with timeout
timeoutCommand :: Int -> FilePath -> [String]
  -> IO (Maybe (ExitCode, String, String))
timeoutCommand time cmd args =
  timeoutSecs time $
    executeProcess cmd args "" -- no input from stdin

{- | runs an action in a different directory without changing the current
     directory globally. -}
withinDirectory :: FilePath -> IO a -> IO a
withinDirectory p a = do
  d <- getCurrentDirectory
  setCurrentDirectory p
  r <- a
  setCurrentDirectory d
  return r

-- | opens a temp file but directly writes content and closes the file
writeTempFile :: String -- ^ Content
  -> FilePath -- ^ Directory in which to create the file
  -> String   -- ^ File name template
  -> IO FilePath -- ^ create file
writeTempFile str tmpDir file = do
  let (fileDirname, fileBasename) = stripDir file
  let tmpDirJoined = tmpDir ++ "/" ++ fileDirname
  createDirectoryIfMissing True tmpDirJoined
  (tmpFile, hdl) <- openTempFileWithDefaultPermissions tmpDirJoined fileBasename
  hPutStr hdl str
  hFlush hdl
  hClose hdl
  return tmpFile

-- | create file in temporary directory (the first argument is the content)
getTempFile :: String -- ^ Content
  -> String   -- ^ File name template
  -> IO FilePath -- ^ create file
getTempFile str file = do
  tmpDir <- getTemporaryDirectory
  writeTempFile str tmpDir file

#ifdef UNIX
getTempFifo :: String -> IO FilePath
getTempFifo f = do
  tmpDir <- getTemporaryDirectory
  (tmpFile, hdl) <- openTempFile tmpDir f
  hClose hdl
  removeFile tmpFile
  createNamedPipe tmpFile $ unionFileModes ownerReadMode ownerWriteMode
  return tmpFile
#else
getTempFifo :: String -> IO FilePath
getTempFifo _ = return ""
#endif

#ifdef UNIX
type Pipe = (IO (), MVar String)
#endif

#ifdef UNIX
openFifo :: FilePath -> IO Pipe
openFifo fp = do
  mvar <- newEmptyMVar
  let readF fd = forever (fmap fst (fdRead fd 100) >>= putMVar mvar)
        `Exception.catch`
        \ e -> const (threadDelay 100) (e :: Exception.IOException)
  let reader = forever $ do
                fd <- openFd fp ReadWrite Nothing defaultFileFlags
                readF fd `Exception.catch`
                 \ e -> closeFd fd >>
                        if isEOFError e then reader
                        else throwIO (e :: Exception.IOException)
  return (reader, mvar)

readFifo' :: MVar String -> IO [String]
readFifo' mvar = do
  x <- unsafeInterleaveIO $ takeMVar mvar
  xs <- unsafeInterleaveIO $ readFifo' mvar
  return $ x : xs

readFifo :: FilePath -> IO ([String], IO ())
readFifo fp = do
  (reader, pipe) <- openFifo fp
  tid <- forkIO reader
  l <- readFifo' pipe
  m <- newEmptyMVar
  forkIO $ takeMVar m >> killThread tid
  return (l, putMVar m ())
#else
readFifo :: FilePath -> IO ([String], IO ())
readFifo _ = return ([], return ())
#endif
