I'll get right to it (I removed a bunch of extraneous code, in case this looks a little funny -- trying to make this a MCVE):
import System.IO
import Control.Monad
import Data.IORef
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
input_line <- getLine
let input = words input_line
let x0 = read (input!!0) :: Int
x <- newIORef x0
loop
loop :: IO ()
loop = do
input_line <- getLine
let the_dir = input_line :: String
putStrLn x
loop
Just to test it I tried outputting x and it's saying it's out of scope. Why? How do I fix it so it is in scope? I need to access the variables but I also need to have them initialized before I enter the loop for the first time.
You can make x a parameter.
import System.IO
import Control.Monad
import Data.IORef
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
input_line <- getLine
let input = words input_line
let x0 = read (input!!0) :: Int
x <- newIORef x0
loop x
loop :: Int -> IO ()
loop x = do
input_line <- getLine
let the_dir = input_line :: String
putStrLn $ show x
loop
Or simply use forever.
import Control.Monad
...
x <- newIORef x0
forever $ do
input_line <- getLine
let the_dir = input_line :: String
putStrLn $ show x
Related
The following example requires the packages of:
- text
- string-conversions
- process
Code:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Example where
import qualified Data.Text as T
import Data.Text (Text)
import Data.Monoid
import Control.Monad.Identity
import System.Process
import GHC.IO.Handle
import Debug.Trace
import Data.String.Conversions
runGhci :: Text -> IO Text
runGhci _ = do
let expr = "print \"test\""
let inputLines = (<> "\n") <$> T.lines expr :: [Text]
print inputLines
createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
(Just pin, Just pout, Just perr, ph) -> do
output <-
forM inputLines (\i -> do
let script = i <> "\n"
do
hPutStr pin $ cs $ script
hFlush pin
x <- hIsEOF pout >>= \case
True -> return ""
False -> hGetLine pout
y <- hIsEOF perr >>= \case
True -> return ""
False -> hGetLine perr
let output = cs $! x ++ y
return $ trace "OUTPUT" $ output
)
let f i o = "ghci>" <> i <> o
let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
print final
terminateProcess ph
pure $ T.strip $ final
_ -> error "Invaild GHCI process"
If I attempt to run the above:
stack ghci src/Example.hs
ghci> :set -XOverloadedStrings
ghci> runGhci ""
["print \"test\"\n"]
It appears to be blocking on hIsEOF perr, according to https://stackoverflow.com/a/26510673/1663462 it sounds like I shouldn't call this function unless there is 'some output' ready to be flushed / read... However how do I handle the case where it does not have any output at that stage? I don't mind periodically 'checking' or having a timeout.
How can I prevent the above from hanging? I've tried various approaches involving hGetContents, hGetLine however they all seem to end up blocking (or closing the handle) in this situation...
I had to use additional threads, MVars, as well as timeouts:
runGhci :: Text -> IO Text
runGhci _ = do
let expr = "123 <$> 123"
let inputLines = filter (/= "") (T.lines expr)
print inputLines
createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
(Just pin, Just pout, Just perr, ph) -> do
output <- do
forM inputLines
(\i -> do
let script = "putStrLn " ++ show magic ++ "\n"
++ cs i ++ "\n"
++ "putStrLn " ++ show magic ++ "\n"
do
stdoutMVar <- newEmptyMVar
stderrMVar <- newMVar ""
hPutStr pin script
hFlush pin
tOutId <- forkIO $ extract' pout >>= putMVar stdoutMVar
tErrId <- forkIO $ do
let f' = hGetLine perr >>= (\l -> modifyMVar_ stderrMVar (return . (++ (l ++ "\n"))))
forever f'
x <- timeout (1 * (10^6)) (takeMVar stdoutMVar) >>= return . fromMaybe "***ghci timed out"
y <- timeout (1 * (10^6)) (takeMVar stderrMVar) >>= return . fromMaybe "***ghci timed out"
killThread tOutId
killThread tErrId
return $ trace "OUTPUT" $ cs $! x ++ y
)
let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
print final
terminateProcess ph
pure $ T.strip $ cs $ final
_ -> error "Invaild GHCI process"
I'm new in haskell and I have following code
module StateTest where
import Control.Monad.State.Lazy
tick :: State Int Int
tick = do n <- get
put (n+1)
return n
plusOne :: Int -> Int
plusOne = execState tick
main = print $ plusOne 1
And I want to print state value after put (n+1) and continue computation like this
tick = do n <- get
put (n+1)
print
return n
How whole code will look following to this?
If you want to run IO actions within a state computation you can change the type of tick to return a StateT Int IO Int and use liftIO. Then you can run it using execStateT:
import Control.Monad.State.Lazy
import Control.Monad.IO.Class (liftIO)
tick :: StateT Int IO Int
tick = do n <- get
put (n+1)
liftIO $ print (n+1)
return n
plusOne :: Int -> IO Int
plusOne = execStateT tick
main = plusOne 1 >> pure ()
Another option, since you would have to use IO anyway to print a value in the intermediate state, would be to use IORef. It's a container that has an updateable value.
module Main where
import Data.IORef
tick :: IORef Int -> IO (IORef Int)
tick ref = do
modifyIORef' ref (+1)
-- you can also print here since it is IO
pure ref
main :: IO ()
main = do
counter <- newIORef 0
tick counter
v2 <- readIORef counter
print v2
tick counter
v2 <- readIORef counter
print v2
You can then clean it up with ReaderT.
module Main where
import Data.IORef
import Control.Monad.Reader
readerTick :: ReaderT (IORef Int) IO ()
readerTick = do
ref <- ask
-- can also print here with liftIO $ print ...
liftIO $ modifyIORef' ref (+1)
main :: IO ()
main = do
counter <- newIORef 0
runReaderT readerTick counter
v1 <- readIORef counter
print v1
runReaderT readerTick counter
v2 <- readIORef counter
print v2
So i've got two files with the following content:
File 1:
Tom 965432145
Bill 932121234
File 2:
Steve 923432323
Tom 933232323
and i want to merge them and write the resulting output to a file named 'out.txt'.
i wrote this function to deal with duplicates (when the same name appears more than once, it choses what number goes into the final file).
the function is called choosing:
choosing :: [String] −> Int −> Int −> Int
choosing ("Name_of_person":_) num1 _ = num1
choosing _ num1 num2
| num2 ‘div‘ 100000000 == 2 = num2
| otherwise = num1
Here's my attempt at this:
import System.IO
import Data.Char
choosing :: [String] −> Int −> Int −> Int
choosing name num1 _ = num1
choosing _ num1 num2
| num2 `div` 100000000 == 2 = num2
| otherwise = num1
main :: IO ()
main = do
in1 <- openFile "in1.txt" ReadMode
in2 <- openFile "in2.txt" ReadMode
out <- openFile "out.txt" WriteMode
processData in1 in2 out
hClose in1
hClose in2
hClose out
processData :: Handle -> Handle -> Handle -> IO ()
processData in1 in2 out =
do ineof <- hIsEOF in1
ineof2 <- h2IsEOF in2
if ineof && ineof2
then return ()
else do inpStr <- hGetLine in1
inp2Str <- h2GetLine in2
num1Int <- num1GetNumber in1
num2Int <- num2GetNumber in2
if inpStr = inp2Str
then PutStrLn out (impStr choosing inpStr num1Int num2Int )
else PutStrLn out (inpStr num1Int)
PutStrLn out (inp2Str num2Int)
processData in1 in2 out
However this kinda of makes sense to me, it doesn't compile and after a while trying to debug this i'm now starting to think there's some serious mistakes here, so i would really appreciate your help on this.
Here's my attempt at something simpler first:
import System.IO
import Data.Char
choosing name num1 _ = num1
choosing _ num1 num2
| num2 `div` 100000000 == 2 = num2
| otherwise = num1
main :: IO ()
main = do
in1 <- openFile "in1.rtf" ReadMode
in2 <- openFile "in2.rtf" ReadMode
out <- openFile "out.rtf" WriteMode
mainloop in1 out
mainloop in2 out
hClose in1
hClose in2
hClose out
mainloop :: Handle -> Handle -> IO ()
mainloop _ out =
do ineof <- hIsEOF in
if ineof
then return ()
else do inpStr <- hGetLine in
hPutStrLn out (inpStr)
mainloop in out
but it's not working either...
UPDATED:
So basically i've been trying to solve my problem, with all the tips i got, i managed to do this:
import System.IO
import Data.Char
- Main function to run the program
main = do
entries1 <- fmap parseEntries $ readFile "in1.txt"
entries2 <- fmap parseEntries $ readFile "in2.txt"
writeFile "out.txt" $ serializeEntries $ mergeEntries entries1 entries2
- Function to deal with duplicates
choosing name num1 _ = num1
choosing _ num1 num2
| num2 `div` 100000000 == 2 = num2
| otherwise = num1
- Function to read a line from a file into a tuple
Now i need help making this function 'cover' the whole file, and not just one line of it.
parseLine :: String -> (String, Int)
parseLine xs = (\(n:i:_) -> (n, read i)) (words xs)
- A function that receives entries, merges them into a single string so that it can be writen to a file.
import Data.Char
tupleToString :: (Int, Char) -> [Char]
tupleToString x = (intToDigit.fst) x:(snd x):[]
tuplesToStrings [] = []
tuplesToStrings (x:xs) = tupleToString x : tuplesToStrings xs
tuplesToString xs = (concat . tuplesToStrings) xs
I think the problem is that your thinking too imperative. In Haskell you usually split your solution in small blocks, and each block does only one thing. It's much easier to reason about one small block, and it's also easier to reuse that block in other parts. For example, here's how I would breakdown the code for this problem:
parseEntries :: String -> [(String, Int)]
A function that receives the content of a file and parses the entries. It the case of the content of in1.txt it would return [("Tom", 965432145), ("Bill", 932121234)]
mergeEntries :: [(String, Int)] -> [(String, Int)] -> [(String, Int)]
A function that receives entries from two files and merges them.
serializeEntries :: [(String, Int)] -> String
A function that receives entries, merges them into a single string so that it can be writen to a file.
Having defined these functions, main becomes as simple as this:
main = do
entries1 <- fmap parseEntries $ readFile "in1.txt"
entries2 <- fmap parseEntries $ readFile "in2.txt"
writeFile "out.txt" $ serializeEntries $ mergeEntries entries1 entries2
Answering to your updated code:
Now that you have a function to parse a line, parseEntries is easy. Use the lines function to split the content by lines, then map parseLine to each line.
tuplesToStrings could be writen much simpler as tuplesToStrings = map tupleToString
I don't see how tuplesToString will help you. Its type doesn't match the type returned by parseLine (parseLine returns a list of (String, Int) while tuplesToString expects a list of (Int, Char)). And it doesn't even insert spaces between words or between lines.
Here's a possible implementation for serializeEntries (using Text.Printf module):
serializeEntries entries = concatMap (uncurry $ printf "%s %d\n") entries
I would like to optionally abort a getChar action.
I need the following function:
getChar' :: (Char -> IO ()) -> IO (IO ())
In case of abort <- getChar' callback , a character is read from standard input, unless abort is called before a character is available.
If a character is read, callback is called with it.
I have the following prototype implementation:
import Control.Monad
import Control.Concurrent
getChar' :: (Char -> IO ()) -> IO (IO ())
getChar' callback = do
v <- newEmptyMVar
tid <- forkIO $ do
c <- getChar
b <- tryPutMVar v ()
when b $ callback c
return $ do
b <- tryPutMVar v ()
when b $ killThread tid
The problem is that killThread may abort the thread after reading the char but before putting () into the MVar.
I have no idea how to solve this problem, is it possible at all with the base package?
If not, have you seen a similar function implemented in other packages?
I think the easiest way to achieve this is to perform your own buffering. Here's a simple prototype. It assumes that you call launchIOThread exactly once in your program. It doesn't handle EOF or other IO exceptions, but that should be easy.
import Control.Concurrent
import Control.Concurrent.STM
import Data.Maybe
import Control.Monad
type Buffer = TVar (Maybe Char)
launchIOThread :: IO Buffer
launchIOThread = do
buf <- atomically $ newTVar Nothing
_ <- forkIO $ ioThread buf
return buf
ioThread :: Buffer -> IO ()
ioThread buf = loop where
loop =
join $ atomically $ do
contents <- readTVar buf
if isJust contents -- no-one has taken the character yet
then retry -- relax
else return $ do
c <- getChar
atomically $ writeTVar buf (Just c)
loop
getChar' :: Buffer -> (Char -> IO ()) -> IO (IO ())
getChar' buf callback = do
abortFlag <- atomically $ newTVar False
_ <- forkIO $ doGetChar abortFlag
return $ atomically $ writeTVar abortFlag True
where
doGetChar abortFlag = join $ atomically $ do
mbC <- readTVar buf
abort <- readTVar abortFlag
case mbC of
Just c ->
do writeTVar buf Nothing; return $ callback c
Nothing | abort -> return $ return ()
_ -> retry
What you want to do is use exception-handling constructs such that regardless of exceptions, the MVar is always left in a safe state. In particular, you probably want withMVar.
I call an external program inside a function. Now i would like to timeout this function and not just the external program. But after the function times out, the external program is still running on my computer (i'm using debian) until it finishes its computation, after that its thread still remains in the process table as a subthread of my main program until the main program terminates.
Here are two minimal examples which illustrates what i would like to do. The first uses unsafePerformIO, the second is completely in the IO monad. I don't really depend on the unsafePerformIO but would like to keep it if possible. The described problem occures with and without it.
With unsafePerformIO
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
main = do
x <- time $ timeoutP (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
timeoutP :: Int -> a -> IO (Maybe a)
timeoutP t fun = timeout t $ return $! fun
mytest :: Int -> String
mytest n =
let
x = runOnExternalProgram $ n * 1000
in
x ++ ". Indeed."
runOnExternalProgram :: Int -> String
runOnExternalProgram n = unsafePerformIO $ do
-- convert the input to a parameter of the external program
let x = show $ n + 12
-- run the external program
-- (here i use "sleep" to indicate a slow computation)
answer <- readProcess "sleep" [x] ""
-- convert the output as needed
let verboseAnswer = "External program answered: " ++ answer
return verboseAnswer
Without unsafePerformIO
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
main = do
x <- time $ timeout (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
mytest :: Int -> IO String
mytest n = do
x <- runOnExternalProgram $ n * 1000
return $ x ++ ". Indeed."
runOnExternalProgram :: Int -> IO String
runOnExternalProgram n = do
-- convert the input to a parameter for the external program:
let x = show $ n + 12
-- run the external program
-- (here i use "sleep" to indicate a slow computation):
answer <- readProcess "sleep" [x] ""
-- convert the output as needed:
let verboseAnswer = "External program answered: " ++ answer
return verboseAnswer
Maybe bracket can be of help here, but i don't really know how.
Edit: I adopted John L's answer. Now i am using the following:
import Control.Concurrent
import Control.Exception
import System.Exit
import System.IO
import System.IO.Error
import System.Posix.Signals
import System.Process
import System.Process.Internals
safeCreateProcess :: String -> [String] -> StdStream -> StdStream -> StdStream
-> ( ( Maybe Handle
, Maybe Handle
, Maybe Handle
, ProcessHandle
) -> IO a )
-> IO a
safeCreateProcess prog args streamIn streamOut streamErr fun = bracket
( do
h <- createProcess (proc prog args)
{ std_in = streamIn
, std_out = streamOut
, std_err = streamErr
, create_group = True }
return h
)
-- "interruptProcessGroupOf" is in the new System.Process. Since some
-- programs return funny exit codes i implemented a "terminateProcessGroupOf".
-- (\(_, _, _, ph) -> interruptProcessGroupOf ph >> waitForProcess ph)
(\(_, _, _, ph) -> terminateProcessGroup ph >> waitForProcess ph)
fun
{-# NOINLINE safeCreateProcess #-}
safeReadProcess :: String -> [String] -> String -> IO String
safeReadProcess prog args str =
safeCreateProcess prog args CreatePipe CreatePipe Inherit
(\(Just inh, Just outh, _, ph) -> do
hPutStr inh str
hClose inh
-- fork a thread to consume output
output <- hGetContents outh
outMVar <- newEmptyMVar
forkIO $ evaluate (length output) >> putMVar outMVar ()
-- wait on output
takeMVar outMVar
hClose outh
return output
-- The following would be great, if some programs did not return funny
-- exit codes!
-- ex <- waitForProcess ph
-- case ex of
-- ExitSuccess -> return output
-- ExitFailure r ->
-- fail ("spawned process " ++ prog ++ " exit: " ++ show r)
)
terminateProcessGroup :: ProcessHandle -> IO ()
terminateProcessGroup ph = do
let (ProcessHandle pmvar) = ph
ph_ <- readMVar pmvar
case ph_ of
OpenHandle pid -> do -- pid is a POSIX pid
signalProcessGroup 15 pid
otherwise -> return ()
This solves my problem. It kills all child processes of the spawned process and that at the right time.
Kind regards.
Edit: it is possible to get the pid of the spawned process. You can do so with code like the following:
-- highly non-portable, and liable to change between versions
import System.Process.Internals
-- from the finalizer of the bracketed function
-- `ph` is a ProcessHandle as returned by createProcess
(\(_,_,_,ph) -> do
let (ProcessHandle pmvar) = ph
ph_ <- takeMVar pmvar
case ph_ of
OpenHandle pid -> do -- pid is a POSIX pid
... -- do stuff
putMVar pmvar ph_
If you kill the process, instead of putting the open ph_ into the mvar you should create an appropriate ClosedHandle and put that back instead. It's important that this code executes masked (bracket will do this for you).
Now that you have a POSIX id you can use system calls or shell out to kill as necessary. Just be careful that your Haskell executable isn't in the same process group if you go that route.
/end edit
This behavior seems sort of sensible. The documentation for timeout claims that it doesn't work at all for non-Haskell code, and indeed I don't see any way that it could generically. What's happening is that readProcess spawns a new process, but then is timed out while waiting for output from that process. It seems that readProcess doesn't terminate the spawned process when it's aborted abnormally. This could be a bug in readProcess, or it could be by design.
As a workaround, I think you'll need to implement some of this yourself. timeout works by raising an async exception in a spawned thread. If you wrap your runOnExternalProgram in an exception handler, you'll get the behavior you want.
The key function here is the new runOnExternalProgram, which is a combination of your original function and readProcess. It would be better (more modular, more reusable, more maintainable) to make a new readProcess that kills the spawned process when an exception is raised, but I'll leave that as an exercise.
module Main where
import System.Timeout
import Criterion.Measurement
import System.IO.Unsafe
import System.Process
import Control.Exception
import System.IO
import System.IO.Error
import GHC.IO.Exception
import System.Exit
import Control.Concurrent.MVar
import Control.Concurrent
main = do
x <- time $ timeoutP (1 * 1000000) $ mytest 2
y <- getLine
putStrLn $ show x ++ y
timeoutP :: Int -> IO a -> IO (Maybe a)
timeoutP t fun = timeout t $ fun
mytest :: Int -> IO String
mytest n = do
x <- runOnExternalProgram $ n * 1000
return $ x ++ ". Indeed."
runOnExternalProgram :: Int -> IO String
runOnExternalProgram n =
-- convert the input to a parameter of the external program
let x = show $ n + 12
in bracketOnError
(createProcess (proc "sleep" [x]){std_in = CreatePipe
,std_out = CreatePipe
,std_err = Inherit})
(\(Just inh, Just outh, _, pid) -> terminateProcess pid >> waitForProcess pid)
(\(Just inh, Just outh, _, pid) -> do
-- fork a thread to consume output
output <- hGetContents outh
outMVar <- newEmptyMVar
forkIO $ evaluate (length output) >> putMVar outMVar ()
-- no input in this case
hClose inh
-- wait on output
takeMVar outMVar
hClose outh
-- wait for process
ex <- waitForProcess pid
case ex of
ExitSuccess -> do
-- convert the output as needed
let verboseAnswer = "External program answered: " ++ output
return verboseAnswer
ExitFailure r ->
ioError (mkIOError OtherError ("spawned process exit: " ++ show r) Nothing Nothing) )