{-# 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
  , FileInfo(..)
  ) 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

data FileInfo = FileInfo {
    FileInfo -> Bool
wasDownloaded :: Bool,
    FileInfo -> FilePath
filePath :: FilePath
  }

{- | 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 :: Handle -> Int -> Int -> FilePath -> IO ()
verbMsg hdl :: Handle
hdl v :: Int
v lvl :: Int
lvl = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
v) (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStr Handle
hdl

-- | Same as 'verbMsg' but with a newline at the end
verbMsgLn :: Handle -> Int -> Int -> String -> IO ()
verbMsgLn :: Handle -> Int -> Int -> FilePath -> IO ()
verbMsgLn hdl :: Handle
hdl v :: Int
v lvl :: Int
lvl = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
v) (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl

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

-- | 'verbMsgLn' with stdout as handle
verbMsgIOLn :: Int -> Int -> String -> IO ()
verbMsgIOLn :: Int -> Int -> FilePath -> IO ()
verbMsgIOLn = Handle -> Int -> Int -> FilePath -> IO ()
verbMsgLn Handle
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 :: [a] -> [a] -> [a] -> [a]
replace sl :: [a]
sl r :: [a]
r = case [a]
sl of
  [] -> FilePath -> [a] -> [a]
forall a. HasCallStack => FilePath -> a
error "Common.Utils.replace: empty list"
  _ -> [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Maybe ([a], [a])) -> [a] -> [[a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\ l :: [a]
l -> case [a]
l of
    [] -> Maybe ([a], [a])
forall a. Maybe a
Nothing
    hd :: a
hd : tl :: [a]
tl -> ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just (([a], [a]) -> Maybe ([a], [a])) -> ([a], [a]) -> Maybe ([a], [a])
forall a b. (a -> b) -> a -> b
$ case [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
sl [a]
l of
      Nothing -> ([a
hd], [a]
tl)
      Just rt :: [a]
rt -> ([a]
r, [a]
rt))

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

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

-- | /O(1)/ test if the set's size is greater one
hasMany :: Set.Set a -> Bool
hasMany :: Set a -> Bool
hasMany s :: Set a
s = Set a -> Int
forall a. Set a -> Int
Set.size Set a
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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 :: [[a]] -> [[a]]
combine = [[a]] -> [[a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
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 :: FilePath -> FilePath
trim = FilePath -> FilePath
trimRight (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
trimLeft

-- | trims a string only on the left side
trimLeft :: String -> String
trimLeft :: FilePath -> FilePath
trimLeft = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- | trims a string only on the right side
trimRight :: String -> String
trimRight :: FilePath -> FilePath
trimRight = (Char -> FilePath -> FilePath) -> FilePath -> FilePath -> FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ c :: Char
c cs :: FilePath
cs -> if Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
cs then [] else Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
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 :: FilePath -> FilePath
toSnakeCase c :: FilePath
c = if FilePath -> Bool
hasBump FilePath
c then FilePath -> FilePath
unScream FilePath
c else FilePath -> FilePath
mkSnake FilePath
c where
  hasBump :: FilePath -> Bool
hasBump s :: FilePath
s = case FilePath
s of
    a :: Char
a : b :: Char
b : _ -> Char -> Bool
isUpper Char
a Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
b
    _ -> Bool
False
  unScream :: FilePath -> FilePath
unScream s :: FilePath
s = case FilePath
s of
    a :: Char
a : r :: FilePath
r -> Char -> Char
toLower Char
a Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
mkSnake FilePath
r
    _ -> FilePath
s
  mkSnake :: FilePath -> FilePath
mkSnake s :: FilePath
s = let newSnake :: FilePath -> FilePath
newSnake t :: FilePath
t = '_' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
unScream FilePath
t in case FilePath
s of
    a :: Char
a : r :: FilePath
r@(b :: Char
b : _) | FilePath -> Bool
hasBump [Char
b, Char
a] -> Char
a Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
newSnake FilePath
r
    _ | FilePath -> Bool
hasBump FilePath
s -> FilePath -> FilePath
newSnake FilePath
s
    _ -> FilePath -> FilePath
unScream FilePath
s

-- | strip a prefix from a string, if possible
tryToStripPrefix :: String -> String -> String
tryToStripPrefix :: FilePath -> FilePath -> FilePath
tryToStripPrefix prefix :: FilePath
prefix s :: FilePath
s = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
s (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
prefix FilePath
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 :: (a -> b -> Maybe b) -> b -> [a] -> [a]
nubWith f :: a -> b -> Maybe b
f s :: b
s es :: [a]
es = case [a]
es of
  [] -> []
  e :: a
e : rs :: [a]
rs -> case a -> b -> Maybe b
f a
e b
s of
       Just s' :: b
s' -> a
e a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b -> Maybe b) -> b -> [a] -> [a]
forall a b. (a -> b -> Maybe b) -> b -> [a] -> [a]
nubWith a -> b -> Maybe b
f b
s' [a]
rs
       Nothing -> (a -> b -> Maybe b) -> b -> [a] -> [a]
forall a b. (a -> b -> Maybe b) -> b -> [a] -> [a]
nubWith a -> b -> Maybe b
f b
s [a]
rs

nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd = (a -> a) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn a -> a
forall a. a -> a
id

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

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

readMaybe :: Read a => String -> Maybe a
readMaybe :: FilePath -> Maybe a
readMaybe s :: FilePath
s = case ((a, FilePath) -> Bool) -> [(a, FilePath)] -> [(a, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (FilePath -> Bool)
-> ((a, FilePath) -> FilePath) -> (a, FilePath) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([(a, FilePath)] -> [(a, FilePath)])
-> [(a, FilePath)] -> [(a, FilePath)]
forall a b. (a -> b) -> a -> b
$ ReadS a
forall a. Read a => ReadS a
reads FilePath
s of
  [(a :: a
a, _)] -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  _ -> Maybe a
forall a. Maybe 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 :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM f :: acc -> x -> m (acc, y)
f s :: acc
s l :: [x]
l = case [x]
l of
  [] -> (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s, [])
  x :: x
x : xs :: [x]
xs -> do
    (s' :: acc
s', y :: y
y) <- acc -> x -> m (acc, y)
f acc
s x
x
    (s'' :: acc
s'', ys :: [y]
ys) <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
s' [x]
xs
    (acc, [y]) -> m (acc, [y])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s'', y
y y -> [y] -> [y]
forall a. a -> [a] -> [a]
: [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 :: (a -> b -> c)
-> (acc -> a -> m (acc, b)) -> acc -> [a] -> m (acc, [c])
mapAccumLCM g :: a -> b -> c
g f :: acc -> a -> m (acc, b)
f s :: acc
s l :: [a]
l = case [a]
l of
  [] -> (acc, [c]) -> m (acc, [c])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s, [])
  x :: a
x : xs :: [a]
xs -> do
    (s' :: acc
s', y :: b
y) <- acc -> a -> m (acc, b)
f acc
s a
x
    (s'' :: acc
s'', ys :: [c]
ys) <- (a -> b -> c)
-> (acc -> a -> m (acc, b)) -> acc -> [a] -> m (acc, [c])
forall (m :: * -> *) a b c acc.
Monad m =>
(a -> b -> c)
-> (acc -> a -> m (acc, b)) -> acc -> [a] -> m (acc, [c])
mapAccumLCM a -> b -> c
g acc -> a -> m (acc, b)
f acc
s' [a]
xs
    (acc, [c]) -> m (acc, [c])
forall (m :: * -> *) a. Monad m => a -> m a
return (acc
s'', a -> b -> c
g a
x b
y c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
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 :: (a -> m [b]) -> t a -> m [b]
concatMapM f :: a -> m [b]
f = (t [b] -> [b]) -> m (t [b]) -> m [b]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM t [b] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m (t [b]) -> m [b]) -> (t a -> m (t [b])) -> t a -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m [b]) -> t a -> m (t [b])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
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 :: Map a b -> Map a a -> Map a a -> Map a a
composeMap s :: Map a b
s m1 :: Map a a
m1 m2 :: Map a a
m2 = if Map a a -> Bool
forall k a. Map k a -> Bool
Map.null Map a a
m2 then Map a a
m1 else Map a a -> Map a b -> Map a a
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection
  ((a -> a -> Map a a -> Map a a) -> Map a a -> Map a a -> Map a a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey ( \ i :: a
i j :: a
j ->
    let k :: a
k = a -> a -> Map a a -> a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault a
j a
j Map a a
m2 in
    if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
k then a -> Map a a -> Map a a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
i else a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
i a
k) Map a a
m2 Map a a
m1) Map a b
s

-- | keep only minimal elements
keepMins :: (a -> a -> Bool) -> [a] -> [a]
keepMins :: (a -> a -> Bool) -> [a] -> [a]
keepMins lt :: a -> a -> Bool
lt l :: [a]
l = case [a]
l of
    [] -> []
    x :: a
x : r :: [a]
r -> let s :: [a]
s = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Bool
lt a
x) [a]
r
                 m :: [a]
m = (a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
keepMins a -> a -> Bool
lt [a]
s
              in if (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
`lt` a
x) [a]
s then [a]
m
                 else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
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 :: a -> [a] -> [[a]]
splitOn x :: a
x = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
splitBy a
x

-- | split a colon (or on windows semicolon) separated list of paths
splitPaths :: String -> [FilePath]
splitPaths :: FilePath -> [FilePath]
splitPaths = Char -> FilePath -> [FilePath]
forall a. Eq a => a -> [a] -> [[a]]
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 :: a -> [a] -> [[a]]
splitBy c :: a
c l :: [a]
l = let (p :: [a]
p, q :: [a]
q) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) [a]
l in [a]
p [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: case [a]
q of
     [] -> []
     _ : r :: [a]
r -> a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
splitBy a
c [a]
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 :: [a] -> [a] -> [[a]]
splitByList sep :: [a]
sep l :: [a]
l = case [a]
l of
    [] -> [[]]
    h :: a
h : t :: [a]
t -> case [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
sep [a]
l of
      Just suf :: [a]
suf -> [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitByList [a]
sep [a]
suf
      Nothing -> let f :: [a]
f : r :: [[a]]
r = [a] -> [a] -> [[a]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitByList [a]
sep [a]
t in (a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
f) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
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 :: FilePath -> Maybe (FilePath, Int)
numberSuffix s :: FilePath
s =
    let f :: Char -> (Int, Int, Bool) -> (Int, Int, Bool)
f a :: Char
a r :: (Int, Int, Bool)
r@(x :: Int
x, y :: Int
y, b :: Bool
b) =
            let b' :: Bool
b' = Char -> Bool
isDigit Char
a
                y' :: Int
y' = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
digitToInt Char
a
                out :: (Int, Int, Bool)
out | Bool -> Bool
not Bool
b = (Int, Int, Bool)
r
                    | Bool
b Bool -> Bool -> Bool
&& Bool
b' = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* 10, Int
y', Bool
b')
                    | Bool
otherwise = (Int
x, Int
y, Bool
False)
            in (Int, Int, Bool)
out
    in case (Char -> (Int, Int, Bool) -> (Int, Int, Bool))
-> (Int, Int, Bool) -> FilePath -> (Int, Int, Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> (Int, Int, Bool) -> (Int, Int, Bool)
f (1, 0, Bool
True) FilePath
s of
         (1, _, _) ->
             Maybe (FilePath, Int)
forall a. Maybe a
Nothing
         (p :: Int
p, n :: Int
n, _) ->
             (FilePath, Int) -> Maybe (FilePath, Int)
forall a. a -> Maybe a
Just (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
p)) FilePath
s, Int
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 :: FilePath -> FilePath
basename = (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ((FilePath, FilePath) -> FilePath)
-> (FilePath -> (FilePath, FilePath)) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath, FilePath)
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 :: FilePath -> FilePath
dirname = (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath -> (FilePath, FilePath)) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath, FilePath)
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 :: [FilePath] -> FilePath -> (FilePath, FilePath, Maybe FilePath)
fileparse sufs :: [FilePath]
sufs fp :: FilePath
fp = let (path :: FilePath
path, base :: FilePath
base) = FilePath -> (FilePath, FilePath)
stripDir FilePath
fp
                        (base' :: FilePath
base', suf :: Maybe FilePath
suf) = [FilePath] -> FilePath -> (FilePath, Maybe FilePath)
stripSuffix [FilePath]
sufs FilePath
base
                    in (FilePath
base', FilePath
path, Maybe FilePath
suf)

stripDir :: FilePath -> (FilePath, FilePath)
stripDir :: FilePath -> (FilePath, FilePath)
stripDir =
    (\ (x :: FilePath
x, y :: FilePath
y) -> (if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
y then "./" else FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
y, FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
x))
    ((FilePath, FilePath) -> (FilePath, FilePath))
-> (FilePath -> (FilePath, FilePath))
-> FilePath
-> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/') (FilePath -> (FilePath, FilePath))
-> (FilePath -> FilePath) -> FilePath -> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse

stripSuffix :: [String] -> FilePath -> (FilePath, Maybe String)
stripSuffix :: [FilePath] -> FilePath -> (FilePath, Maybe FilePath)
stripSuffix suf :: [FilePath]
suf fp :: FilePath
fp = case (Maybe (FilePath, FilePath) -> Bool)
-> [Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe (FilePath, FilePath) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)])
-> [Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe (FilePath, FilePath))
-> [FilePath] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Maybe (FilePath, FilePath)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripSuf FilePath
fp) [FilePath]
suf of
                       Just (x :: FilePath
x, s :: FilePath
s) : _ -> (FilePath
x, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
s)
                       _ -> (FilePath
fp, Maybe FilePath
forall a. Maybe a
Nothing)
    where stripSuf :: [a] -> [a] -> Maybe ([a], [a])
stripSuf f :: [a]
f s :: [a]
s | [a]
s [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [a]
f =
                           ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s) [a]
f, [a]
s)
                       | Bool
otherwise = Maybe ([a], [a])
forall a. Maybe a
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 :: FilePath -> FilePath -> FilePath
makeRelativeDesc dp :: FilePath
dp fp :: FilePath
fp = FilePath -> FilePath -> [FilePath] -> FilePath
f FilePath
dp FilePath
fp []
    where f :: FilePath -> FilePath -> [FilePath] -> FilePath
f "" y :: FilePath
y l :: [FilePath]
l = [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
l [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
y]
          f x :: FilePath
x y :: FilePath
y l :: [FilePath]
l = let y' :: FilePath
y' = FilePath -> FilePath -> FilePath
makeRelative FilePath
x FilePath
y
                    in if FilePath -> FilePath -> Bool
equalFilePath FilePath
y FilePath
y'
                       then FilePath -> FilePath -> [FilePath] -> FilePath
f (FilePath -> FilePath
takeDirectory FilePath
x) FilePath
y ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ ".." FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
l
                       else [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
l [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
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 :: [k] -> Map k e -> Map k e
filterMapWithList = Set k -> Map k e -> Map k e
forall k e. Ord k => Set k -> Map k e -> Map k e
filterMapWithSet (Set k -> Map k e -> Map k e)
-> ([k] -> Set k) -> [k] -> Map k e -> Map k e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [k] -> Set k
forall a. Ord a => [a] -> Set a
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 :: Set k -> Map k e -> Map k e
filterMapWithSet s :: Set k
s = (k -> e -> Bool) -> Map k e -> Map k e
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ k :: k
k _ -> k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member k
k Set 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 :: a -> FilePath -> (FilePath -> Maybe a) -> IO a
getEnvSave defValue :: a
defValue envVar :: FilePath
envVar readFun :: FilePath -> Maybe a
readFun =
    ([(FilePath, FilePath)] -> a) -> IO [(FilePath, FilePath)] -> IO a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a -> (FilePath -> a) -> Maybe FilePath -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
defValue (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defValue (Maybe a -> a) -> (FilePath -> Maybe a) -> FilePath -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe a
readFun)
           (Maybe FilePath -> a)
-> ([(FilePath, FilePath)] -> Maybe FilePath)
-> [(FilePath, FilePath)]
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
envVar) IO [(FilePath, FilePath)]
getEnvironment

-- | get environment variable
getEnvDef :: String -- ^ environment variable
          -> String -- ^  default value
          -> IO String
getEnvDef :: FilePath -> FilePath -> IO FilePath
getEnvDef envVar :: FilePath
envVar defValue :: FilePath
defValue = FilePath -> FilePath -> (FilePath -> Maybe FilePath) -> IO FilePath
forall a. a -> FilePath -> (FilePath -> Maybe a) -> IO a
getEnvSave FilePath
defValue FilePath
envVar FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just

-- | the timeout function taking seconds instead of microseconds
timeoutSecs :: Int -> IO a -> IO (Maybe a)
timeoutSecs :: Int -> IO a -> IO (Maybe a)
timeoutSecs time :: Int
time = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int -> IO a -> IO (Maybe a)) -> Int -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ let
  m :: Int
m = 1000000
  u :: Int
u = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
forall a. Bounded a => a
maxBound Int
m
  in if Int
time Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
u then Int
forall a. Bounded a => a
maxBound else
     if Int
time Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1 then 100000 -- 1/10 of a second
     else Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 :: FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
executeProcess cmd :: FilePath
cmd args :: [FilePath]
args input :: FilePath
input = do
  Maybe FilePath
mp <- FilePath -> IO (Maybe FilePath)
findExecutable FilePath
cmd
  case Maybe FilePath
mp of
    Nothing -> (ExitCode, FilePath, FilePath) -> IO (ExitCode, FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure 127, "", "command not found: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd)
    Just exe :: FilePath
exe -> FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
exe [FilePath]
args FilePath
input

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

-- | runs a command with timeout
timeoutCommand :: Int -> FilePath -> [String]
  -> IO (Maybe (ExitCode, String, String))
timeoutCommand :: Int
-> FilePath
-> [FilePath]
-> IO (Maybe (ExitCode, FilePath, FilePath))
timeoutCommand time :: Int
time cmd :: FilePath
cmd args :: [FilePath]
args =
  Int
-> IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall a. Int -> IO a -> IO (Maybe a)
timeoutSecs Int
time (IO (ExitCode, FilePath, FilePath)
 -> IO (Maybe (ExitCode, FilePath, FilePath)))
-> IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$
    FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
executeProcess FilePath
cmd [FilePath]
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 :: FilePath -> IO a -> IO a
withinDirectory p :: FilePath
p a :: IO a
a = do
  FilePath
d <- IO FilePath
getCurrentDirectory
  FilePath -> IO ()
setCurrentDirectory FilePath
p
  a
r <- IO a
a
  FilePath -> IO ()
setCurrentDirectory FilePath
d
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: FilePath -> FilePath -> FilePath -> IO FilePath
writeTempFile str :: FilePath
str tmpDir :: FilePath
tmpDir file :: FilePath
file = do
  let (fileDirname :: FilePath
fileDirname, fileBasename :: FilePath
fileBasename) = FilePath -> (FilePath, FilePath)
stripDir FilePath
file
  let tmpDirJoined :: FilePath
tmpDirJoined = FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fileDirname
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
tmpDirJoined
  (tmpFile :: FilePath
tmpFile, hdl :: Handle
hdl) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFileWithDefaultPermissions FilePath
tmpDirJoined FilePath
fileBasename
  Handle -> FilePath -> IO ()
hPutStr Handle
hdl FilePath
str
  Handle -> IO ()
hFlush Handle
hdl
  Handle -> IO ()
hClose Handle
hdl
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmpFile

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

#ifdef UNIX
getTempFifo :: String -> IO FilePath
getTempFifo :: FilePath -> IO FilePath
getTempFifo f :: FilePath
f = do
  FilePath
tmpDir <- IO FilePath
getTemporaryDirectory
  (tmpFile :: FilePath
tmpFile, hdl :: Handle
hdl) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpDir FilePath
f
  Handle -> IO ()
hClose Handle
hdl
  FilePath -> IO ()
removeFile FilePath
tmpFile
  FilePath -> FileMode -> IO ()
createNamedPipe FilePath
tmpFile (FileMode -> IO ()) -> FileMode -> IO ()
forall a b. (a -> b) -> a -> b
$ FileMode -> FileMode -> FileMode
unionFileModes FileMode
ownerReadMode FileMode
ownerWriteMode
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmpFile
#else
getTempFifo :: String -> IO FilePath
getTempFifo _ = return ""
#endif

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

#ifdef UNIX
openFifo :: FilePath -> IO Pipe
openFifo :: FilePath -> IO Pipe
openFifo fp :: FilePath
fp = do
  MVar FilePath
mvar <- IO (MVar FilePath)
forall a. IO (MVar a)
newEmptyMVar
  let readF :: Fd -> IO ()
readF fd :: Fd
fd = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (((FilePath, ByteCount) -> FilePath)
-> IO (FilePath, ByteCount) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, ByteCount) -> FilePath
forall a b. (a, b) -> a
fst (Fd -> ByteCount -> IO (FilePath, ByteCount)
fdRead Fd
fd 100) IO FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar FilePath -> FilePath -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar FilePath
mvar)
        IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
        \ e :: IOException
e -> IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (Int -> IO ()
threadDelay 100) (IOException
e :: Exception.IOException)
  let reader :: IO ()
reader = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Fd
fd <- FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
fp OpenMode
ReadWrite Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
                Fd -> IO ()
readF Fd
fd IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch`
                 \ e :: IOException
e -> Fd -> IO ()
closeFd Fd
fd IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                        if IOException -> Bool
isEOFError IOException
e then IO ()
reader
                        else IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOException
e :: Exception.IOException)
  Pipe -> IO Pipe
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
reader, MVar FilePath
mvar)

readFifo' :: MVar String -> IO [String]
readFifo' :: MVar FilePath -> IO [FilePath]
readFifo' mvar :: MVar FilePath
mvar = do
  FilePath
x <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
unsafeInterleaveIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ MVar FilePath -> IO FilePath
forall a. MVar a -> IO a
takeMVar MVar FilePath
mvar
  [FilePath]
xs <- IO [FilePath] -> IO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ MVar FilePath -> IO [FilePath]
readFifo' MVar FilePath
mvar
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
x FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs

readFifo :: FilePath -> IO ([String], IO ())
readFifo :: FilePath -> IO ([FilePath], IO ())
readFifo fp :: FilePath
fp = do
  (reader :: IO ()
reader, pipe :: MVar FilePath
pipe) <- FilePath -> IO Pipe
openFifo FilePath
fp
  ThreadId
tid <- IO () -> IO ThreadId
forkIO IO ()
reader
  [FilePath]
l <- MVar FilePath -> IO [FilePath]
readFifo' MVar FilePath
pipe
  MVar ()
m <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
m IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
tid
  ([FilePath], IO ()) -> IO ([FilePath], IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
l, MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ())
#else
readFifo :: FilePath -> IO ([String], IO ())
readFifo _ = return ([], return ())
#endif