e655a84bbb62bb1c66993fda5e74b04feda14dc6kess{-# LANGUAGE CPP #-}

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess{- |

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessModule : $Header$

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessDescription : utility functions that can't be found in the libraries

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessCopyright : (c) Klaus Luettich, Uni Bremen 2002-2006

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessLicense : GPLv2 or higher, see LICENSE.txt

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessMaintainer : Christian.Maeder@dfki.de

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessStability : provisional

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessPortability : portable

d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowen

d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowenUtility functions that can't be found in the libraries

d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowen but should be shared across Hets.

d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowen-}

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessmodule Common.Utils

d229f940abfb2490dee17979e9a5ff31b7012eb5rbowen ( isSingleton

3f08db06526d6901aa08c110b5bc7dde6bc39905nd , replace

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , hasMany

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , number

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , combine

3f08db06526d6901aa08c110b5bc7dde6bc39905nd , trim

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , trimLeft

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , trimRight

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , nubOrd

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , nubOrdOn

1c8f2418892d98febb00a06b9a4f45f8bcfd80a3nd , atMaybe

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , readMaybe

fac8c35bfb158112226ab43ddf84d59daca5dc30nd , mapAccumLM

d474d8ef01ec5c2a09341cd148851ed383c3287crbowen , mapAccumLCM

d474d8ef01ec5c2a09341cd148851ed383c3287crbowen , concatMapM

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , composeMap

4b575a6b6704b516f22d65a3ad35696d7b9ba372rpluem , keepMins

4b575a6b6704b516f22d65a3ad35696d7b9ba372rpluem , splitOn

4b575a6b6704b516f22d65a3ad35696d7b9ba372rpluem , splitPaths

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , splitBy

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , splitByList

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , numberSuffix

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , basename

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , dirname

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , fileparse

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , stripDir

30471a4650391f57975f60bbb6e4a90be7b284bfhumbedooh , stripSuffix

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , makeRelativeDesc

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , getEnvSave

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , getEnvDef

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , filterMapWithList

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , timeoutSecs

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , executeProcess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , timeoutCommand

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , withinDirectory

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , writeTempFile

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , getTempFile

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , getTempFifo

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , readFifo

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , verbMsg

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , verbMsgLn

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , verbMsgIO

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess , verbMsgIOLn

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess ) where

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Data.Char

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Data.List

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Data.Maybe

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport qualified Data.Map as Map

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport qualified Data.Set as Set

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Directory

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Environment

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Exit

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.FilePath (joinPath, makeRelative, equalFilePath, takeDirectory)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.IO

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.IO.Error (isEOFError)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Process

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Timeout

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess#ifdef UNIX

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Posix.Files (createNamedPipe, unionFileModes,

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess ownerReadMode, ownerWriteMode)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.Posix.IO (OpenMode (ReadWrite), defaultFileFlags,

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess openFd, closeFd, fdRead)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

d1348237b33bc1755b9f1165eea52317465a7671ndimport Control.Concurrent (threadDelay, forkIO, killThread)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Control.Exception as Exception

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport System.IO.Unsafe (unsafeInterleaveIO)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess#endif

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessimport Control.Monad

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess{- | Writes the message to the given handle unless the verbosity is less than

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessthe message level. -}

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsg :: Handle -- ^ Output handle

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess -> Int -- ^ global verbosity

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess -> Int -- ^ message level

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess -> String -- ^ message level

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess -> IO ()

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsg hdl v lvl = when (lvl <= v) . hPutStr hdl

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | Same as 'verbMsg' but with a newline at the end

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgLn :: Handle -> Int -> Int -> String -> IO ()

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgLn hdl v lvl = when (lvl <= v) . hPutStrLn hdl

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | 'verbMsg' with stdout as handle

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgIO :: Int -> Int -> String -> IO ()

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgIO = verbMsg stdout

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | 'verbMsgLn' with stdout as handle

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgIOLn :: Int -> Int -> String -> IO ()

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessverbMsgIOLn = verbMsgLn stdout

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | replace first (non-empty) sublist with second one in third argument list

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessreplace :: Eq a => [a] -> [a] -> [a] -> [a]

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessreplace sl r = case sl of

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess [] -> error "Common.Utils.replace: empty list"

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess _ -> concat . unfoldr (\ l -> case l of

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess [] -> Nothing

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess hd : tl -> Just $ case stripPrefix sl l of

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess Nothing -> ([hd], tl)

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess Just rt -> (r, rt))

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | add indices to a list starting from one

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessnumber :: [a] -> [(a, Int)]

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessnumber = flip zip [1 ..]

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | /O(1)/ test if the set's size is one

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessisSingleton :: Set.Set a -> Bool

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessisSingleton s = Set.size s == 1

1c8f2418892d98febb00a06b9a4f45f8bcfd80a3nd

e655a84bbb62bb1c66993fda5e74b04feda14dc6kess-- | /O(1)/ test if the set's size is greater one

fac8c35bfb158112226ab43ddf84d59daca5dc30ndhasMany :: Set.Set a -> Bool

d474d8ef01ec5c2a09341cd148851ed383c3287crbowenhasMany s = Set.size s > 1

d474d8ef01ec5c2a09341cd148851ed383c3287crbowen

30471a4650391f57975f60bbb6e4a90be7b284bfhumbedooh{- | Transform a list @[l1, l2, ... ln]@ to (in sloppy notation)

ba543b319188dc1887607f6d59feddc00e38eee2humbedooh @[[x1, x2, ... xn] | x1 <- l1, x2 <- l2, ... xn <- ln]@

0d0ba3a410038e179b695446bb149cce6264e0abnd (this is just the 'sequence' function!) -}

30471a4650391f57975f60bbb6e4a90be7b284bfhumbedoohcombine :: [[a]] -> [[a]]

0d0ba3a410038e179b695446bb149cce6264e0abndcombine = sequence

0d0ba3a410038e179b695446bb149cce6264e0abnd-- see http://www.haskell.org/pipermail/haskell-cafe/2009-November/069490.html

0d0ba3a410038e179b695446bb149cce6264e0abnd

0d0ba3a410038e179b695446bb149cce6264e0abnd-- | trims a string both on left and right hand side

0d0ba3a410038e179b695446bb149cce6264e0abndtrim :: String -> String

0d0ba3a410038e179b695446bb149cce6264e0abndtrim = trimRight . trimLeft

0d0ba3a410038e179b695446bb149cce6264e0abnd

0d0ba3a410038e179b695446bb149cce6264e0abnd-- | trims a string only on the left side

0d0ba3a410038e179b695446bb149cce6264e0abndtrimLeft :: String -> String

0d0ba3a410038e179b695446bb149cce6264e0abndtrimLeft = dropWhile isSpace

0d0ba3a410038e179b695446bb149cce6264e0abnd

0d0ba3a410038e179b695446bb149cce6264e0abnd-- | trims a string only on the right side

0d0ba3a410038e179b695446bb149cce6264e0abndtrimRight :: String -> String

0d0ba3a410038e179b695446bb149cce6264e0abndtrimRight = foldr (\ c cs -> if isSpace c && null cs then [] else c : cs) ""

30471a4650391f57975f60bbb6e4a90be7b284bfhumbedooh

5effc8b39fae5cd169d17f342bfc265705840014rbowen{- | The 'nubWith' function accepts as an argument a \"stop list\" update

d229f940abfb2490dee17979e9a5ff31b7012eb5rbowenfunction and an initial stop list. The stop list is a set of list elements

0d0ba3a410038e179b695446bb149cce6264e0abndthat 'nubWith' uses as a filter to remove duplicate elements. The stop list

7fec19672a491661b2fe4b29f685bc7f4efa64d4ndis normally initially empty. The stop list update function is given a list

7fec19672a491661b2fe4b29f685bc7f4efa64d4ndelement a and the current stop list b, and returns 'Nothing' if the element is

7fec19672a491661b2fe4b29f685bc7f4efa64d4ndalready in the stop list, else 'Just' b', where b' is a new stop list updated

e655a84bbb62bb1c66993fda5e74b04feda14dc6kessto 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 :: Monad m => (a -> m [b]) -> [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

-- | 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

-- | calls openTempFile 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

(tmpFile, hdl) <- openTempFile tmpDir file

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