Hi all,

I am just sending this because there were some people who thought it could
be useful. It works for Hugs98, but some hacks I use might be specific to
our local system.

I think a built-in module with the same function signatures would be
extremely useful!

Regards,
Koen.

--------------------------------------------------------------------

module Unix
  ( Command  --:: String
  , sys      --:: Command -> IO ()
  
  -- using stdin and stdout
  , sysIn    --:: Command -> String -> IO ()
  , sysOut   --:: Command           -> IO String
  , sysInOut --:: Command -> String -> IO String

  -- using files as arguments
  , sysWithIn    --:: (FilePath -> Command)             -> String -> IO ()
  , sysWithOut   --:: (FilePath -> Command)                       -> IO String
  , sysInWithOut --:: (FilePath -> Command)             -> String -> IO String
  , sysWithInOut --:: (FilePath -> FilePath -> Command) -> String -> IO String

  -- lazily generating output
  , sysOutLazy   --:: Command           -> IO String
  , sysInOutLazy --:: Command -> String -> IO String

  , sysWithOutLazy   --:: (FilePath -> Command)           -> IO String
  , sysInWithOutLazy --:: (FilePath -> Command) -> String -> IO String
  , sysWithInOutLazy --:: (FilePath -> FilePath -> Command) -> String -> IO String
  )
 where

import System( system )
import IO( try )

--------------------------------------------------------------------
-- internal file names

prefix :: FilePath
prefix = "/tmp/hugs-sys-"

lockfile  = prefix ++ "lock"
numfile   = prefix ++ "number"
tmpfile n = prefix ++ show n

--------------------------------------------------------------------
-- comm

type Command
  = String

type Comm
  = ([FilePath] -> String, IO String)

comm0 :: Command -> Comm
comm0 s = (\_ -> s, return "")

comm1 :: (FilePath -> Command) -> Comm
comm1 f = (\(s:_) -> f s, return "")

comm2 :: (FilePath -> FilePath -> Command) -> Comm
comm2 f = (\(s1:s2:_) -> f s1 s2, return "")

-- decorator

type Decorator
  = Comm -> IO Comm

sysDecorate :: Decorator -> Comm -> IO String
sysDecorate decorate comm =
  do (f, after) <- decorate comm
     system (f [])
     after

--------------------------------------------------------------------
-- several decorators

inputArg :: String -> Decorator
inputArg inpS (f, after) =
  do inpF <- uniqueTmpName
     writeFile inpF inpS
     return (\args -> f (args ++ [inpF]), after)

input :: String -> Decorator
input inpS (f, after) =
  do inpF <- uniqueTmpName
     writeFile inpF inpS
     let after' = do s <- after
                     rm inpF
                     return s
     return (\args -> f args ++ " < " ++ inpF, after')

outputArg :: Decorator
outputArg (f, after) =
  do outP <- uniqueTmpName
     writeFile outP ""
     let after' = do s1 <- after
                     s2 <- readFile outP
                     rm outP
                     return (s1 ++ s2)
     return (\args -> f (args ++ [outP]), after')

output :: Decorator
output (f, after) =
  do outP <- uniqueTmpName
     writeFile outP ""
     let after' = do s1 <- after
                     s2 <- readFile outP
                     rm outP
                     return (s1 ++ s2)
     return (\args -> f args ++ " > " ++ outP, after')

outputArgLazy :: Decorator
outputArgLazy (f, after) =
  do outP <- uniqueTmpName
     mkpipe outP
     let after' = do s1 <- after
                     s2 <- readFile outP
                     rm outP
                     return (s1 ++ s2)
     return (\args -> f (args ++ [outP]) ++ " &", after')

outputLazy :: Decorator
outputLazy (f, after) =
  do outP <- uniqueTmpName
     mkpipe outP
     let after' = do s1 <- after
                     s2 <- readFile outP
                     rm outP
                     return (s1 ++ s2)
     return (\args -> f args ++ " > " ++ outP ++ " &", after')

--------------------------------------------------------------------
-- several system functions

sys :: Command -> IO ()
sys comm = void (system comm)

sysIn :: Command -> String -> IO ()
sysIn comm inpS = void $
  sysDecorate (input inpS) (comm0 comm)

sysOut :: Command -> IO String
sysOut comm =
  sysDecorate (output) (comm0 comm)

sysInOut :: Command -> String -> IO String
sysInOut comm inpS =
  sysDecorate (input inpS <> output) (comm0 comm)

sysWithIn :: (FilePath -> Command) -> String -> IO ()
sysWithIn comm inpS = void $
  sysDecorate (inputArg inpS) (comm1 comm)

sysWithOut :: (FilePath -> Command) -> IO String
sysWithOut comm =
  sysDecorate (outputArg) (comm1 comm)

sysInWithOut :: (FilePath -> Command) -> String -> IO String
sysInWithOut comm inpS =
  sysDecorate (input inpS <> outputArg) (comm1 comm)

sysWithInOut :: (FilePath -> FilePath -> Command) -> String -> IO String
sysWithInOut comm inpS =
  sysDecorate (inputArg inpS <> outputArg) (comm2 comm)

-- lazy versions

sysOutLazy :: Command -> IO String
sysOutLazy comm =
  sysDecorate (outputLazy) (comm0 comm)

sysInOutLazy :: Command -> String -> IO String
sysInOutLazy comm inpS =
  sysDecorate (input inpS <> outputLazy) (comm0 comm)

sysWithOutLazy :: (FilePath -> Command) -> IO String
sysWithOutLazy comm =
  sysDecorate (outputArgLazy) (comm1 comm)

sysInWithOutLazy :: (FilePath -> Command) -> String -> IO String
sysInWithOutLazy comm inpS =
  sysDecorate (input inpS <> outputArgLazy) (comm1 comm)

sysWithInOutLazy :: (FilePath -> FilePath -> Command) -> String -> IO String
sysWithInOutLazy comm inpS =
  sysDecorate (inputArg inpS <> outputArgLazy) (comm2 comm)

--------------------------------------------------------------------
-- create unique names

uniqueTmpName :: IO String
uniqueTmpName = mutex $
  do enum <- try (readFile numfile)
     let num = either (const 0) read enum
     num `seq` writeFile numfile (show (num+1))
     chmod "a+w" numfile
     return (tmpfile num)

mutex :: IO a -> IO a
mutex io =
  do lock
     a <- io
     rm lockfile
     return a

--------------------------------------------------------------------
-- calls to system

chmod :: String -> FilePath -> IO ()
chmod s file = void $ system ("chmod " ++ s ++ " " ++ file)

lock :: IO ()
lock = void $ system ("lockfile -1 -l 4 " ++ lockfile)

rm :: FilePath -> IO ()
rm file = void $ system ("rm -f " ++ file)

mkpipe :: FilePath -> IO ()
mkpipe file = void $ system ("mknod " ++ file ++ " p")

--------------------------------------------------------------------
-- monadic help functions

void :: Monad m => m a -> m ()
void m = m >> return ()

(<>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
m1 <> m2 = \x -> m1 x >>= m2

--------------------------------------------------------------------
-- the end.




Reply via email to