https://hackage.haskell.org/package/tasty-bench-0.3.2/docs/Test-Tasty-Bench.html#v:env
I am actually trying to use withResource, but have not gotten env to work either. I can not figure out how to embed bench inside of withResource.
This is what I have:
import qualified Test.Tasty as A
import qualified Test.Tasty.Bench as B
import qualified Test.Tasty.HUnit as H
initResource :: IO (Either String [Int])
initResource = undefined -- read very large file
freeResource :: Either String [Int] -> IO ()
freeResource _ = pure ()
giveTestTree :: IO (Either String [Int]) -> A.TestTree
giveTestTree x = A.testGroup ""
[ H.testCase "" $ do
eiNs <- x
case eiNs of
Left e -> H.assertFailure e
Right ns -> do
_ <- B.bench "" $ B.whnf even $ length ns -- Compiler error: Couldn't match type ‘A.TestTree’ with ‘IO a0’
pure ()
]
main :: IO ()
main = B.defaultMain
[ B.bench "" $ B.whnf even $ length [1,2,3]
, A.withResource initResource freeResource giveTestTree
]
giveTestTree :: IO (Either String [Int]) -> A.TestTree
giveTestTree mx = B.bench ":)" $ B.nfIO $ do
eiNs <- mx
case eiNs of
Left e -> H.assertFailure e
Right ns -> pure $ even $ length ns
Related
I have following program in Haskell that takes input from command line and modifies state of mydata variable:
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
import Text.Regex.PCRE
import System.Console.Haskeline
import System.IO
import System.IO.Unsafe
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as B
import Data.Maybe
import Data.List
import qualified Data.Map as M
data MyDataState = MyDataState {
mydata :: [Int],
showEven :: Bool
} deriving (Show)
myfile :: FilePath
myfile = "data.txt"
defaultFlagValue :: Bool
defaultFlagValue = False
saveDataToFile :: [Int] -> IO ()
saveDataToFile _data = withFile myfile WriteMode $ \h -> hPutStr h (unwords $ map show _data)
{-# NOINLINE loadDataFromFile #-}
loadDataFromFile :: [Int]
loadDataFromFile = map read . words $ B.unpack $ unsafePerformIO $ B.readFile myfile
wordList = [":help", ":q", ":commands", ":show", ":save", ":edit", ":new", ":toggleShowEven"]
searchFunc :: String -> [Completion]
searchFunc str = map simpleCompletion $ filter (str `isPrefixOf`) (wordList)
mySettings :: Settings (StateT MyDataState IO)
mySettings = Settings { historyFile = Just "myhist"
, complete = completeWord Nothing " \t" $ return . searchFunc
, autoAddHistory = True
}
help :: InputT (StateT MyDataState IO) ()
help = liftIO $ mapM_ putStrLn
[ ""
, ":help - this help"
, ":q - quit"
, ":commands - list available commands"
, ""
]
commands :: InputT (StateT MyDataState IO) ()
commands = liftIO $ mapM_ putStrLn
[ ""
, ":show - display data"
, ":save - save results to file"
, ":edit - edit data"
, ":new - generate new element "
, ":toggleShowEven - toggle display of even elements"
, ""
]
toggleFlag :: InputT (StateT MyDataState IO) ()
toggleFlag = do
MyDataState mydata flag <- get
put $ MyDataState mydata (not flag)
instance MonadState s m => MonadState s (InputT m) where
get = lift get
put = lift . put
state = lift . state
parseInput :: String -> InputT (StateT MyDataState IO) ()
parseInput inp
| inp =~ "^\\:q" = return ()
| inp =~ "^\\:he" = help >> mainLoop
| inp =~ "^\\:commands" = commands >> mainLoop
| inp =~ "^\\:toggleShowEven" = toggleFlag >> mainLoop
| inp =~ "^\\:show" = do
MyDataState mydata showEven <- get
liftIO $ putStrLn $ unwords $ if showEven
then map show mydata
else map show $ filter odd mydata
mainLoop
| inp =~ "^\\:save" = do
MyDataState mydata _ <- get
liftIO $ saveDataToFile mydata
mainLoop
| inp =~ "^\\:load" = do
put (MyDataState loadDataFromFile defaultFlagValue)
mainLoop
| inp =~ "^\\:new" = do
MyDataState mydata showEven <- get -- reads the state
inputData <- getInputLine "\tEnter data: "
case inputData of
Nothing -> put ( MyDataState [0] showEven )
Just inputD ->
put $ if null mydata
then MyDataState [read inputD] showEven
else MyDataState (mydata ++ [read inputD]) showEven -- updates the state
mainLoop
| inp =~ ":" = do
outputStrLn $ "\nNo command \"" ++ inp ++ "\"\n"
mainLoop
| otherwise = handleInput inp
handleInput :: String -> InputT (StateT MyDataState IO) ()
handleInput inp = mainLoop
mainLoop :: InputT (StateT MyDataState IO ) ()
mainLoop = do
inp <- getInputLine "% "
maybe (return ()) parseInput inp
greet :: IO ()
greet = mapM_ putStrLn
[ ""
, " MyProgram"
, "=============================="
, "For help type \":help\""
, ""
]
main :: IO ((), MyDataState)
main = do
greet
runStateT (runInputT mySettings mainLoop) MyDataState {mydata = [] , showEven = defaultFlagValue}
Example of interaction with the program above:
*Main> main
MyProgram
==============================
For help type ":help"
% :commands
:show - display data
:save - save results to file
:edit - edit data
:new - generate new element
:toggleShowEven - toggle display of even elements
% :show
% :new
Enter data: 1
% :new
Enter data: 2
% :new
Enter data: 3
% :show
1 3
% :toggleShowEven
% :show
1 2 3
%
As you might have noticed, this program is using command line autocompletion for typical commands such as :show, :edit, :new, etc.
My question is following. Is it possible to extend the list of commands available for autocompletion (wordsList variable) with the values from MyDataState? For example, if mydata contains values 1, 2, 3, I want it to be shown together with commands available for autocompletion - when typing :Tab, I would get the following list of commands instead of just statically defined via wordsList: :help, :q, :commands, :show, :save, :edit, :new, :toggleShowEven, :1, :2, :3. How do I need to extend searchFunc definition to include values defined in MyDataState? Is it possible at all?
In the Settings record, the field complete has type CompletionFunc (StateT MyDataState IO), implying that we have access to the state for autocompletion.
Currently the definition of mySettings uses
complete = completeWord Nothing " \t" $ return . searchFunc
This return wraps a pure function, which thus ignores the stateful context. We can replace that with a computation accessing the state:
complete = completeWord Nothing " \t" $ \str -> do
_data <- get
return (searchFunc _data str)
also changing the type of searchFunc for example to:
searchFunc :: MyDataState -> String -> [Completion]
I have a
foobar :: IO (ParseResult [(String,String)])
ParseResult is a monad defined here: https://hackage.haskell.org/package/haskell-src-exts-1.13.5/docs/Language-Haskell-Exts-Parser.html#t:ParseResult
I want to take those strings and write them to a LaTeXT m () defined in https://hackage.haskell.org/package/HaTeX-3.17.1.0/docs/Text-LaTeX-Base-Writer.html
Running this function results in no file being created.
writeReport2 :: [Char] -> IO (ParseResult (IO ()))
writeReport2 name = do x <- foobar
return $ do y <- x
return $ do z <- (execLaTeXT.docAndGraph) y
renderFile fileName z
where
fileName = name ++ ".tex"
However the code:
writeReport :: t -> LaTeXT IO a -> IO ()
writeReport name report = createLatex >>= renderFile fileName
where
createLatex = execLaTeXT report
fileName = "AAAAA" ++ ".tex"
testFoo = [(" | HaskellExample Example File\n | Two examples are given below:\n\n >>> fib 10\n 55\n\n >>> putStrLn \"foo\\nbar\"\n foo\n bar ","fib :: Int -> Int"),("\n | This is a thing: ","fib = undefined"),("\n | This is a thing:\n","fibar :: String -> Float")]
itWorks = writeReport "AAAA.txt" $ docAndGraph testFoo
Will create a new file.
Both sets of code type check.
I could get writeReport2 working without modification.
I think what might have been your problem is the nested IO action in the return value of writeResport2!
In order to flatten the nested IO actions, I had to use the function join :: Monad m => m (m a) -> m a from Control.Monad:
main :: IO ()
main = join $ fromParseResult <$> writeReport2 "test"
Here is my complete code:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Language.Haskell.Exts.Parser
import Text.LaTeX.Base.Writer
import Text.LaTeX
import Data.String
import Control.Monad
foobar :: IO (ParseResult [(String, String)])
foobar = return (ParseOk testFoo)
testFoo = [ ( " | HaskellExample Example File\n | Two examples are given below:\n\n >>> fib 10\n 55\n\n >>> putStrLn \"foo\\nbar\"\n foo\n bar "
, "fib :: Int -> Int"
)
, ("\n | This is a thing: ", "fib = undefined")
, ("\n | This is a thing:\n", "fibar :: String -> Float")
]
docAndGraph :: Monad m => [(String, String)] -> LaTeXT m ()
docAndGraph x = do
documentclass [] article
document $
raw (fromString (show x))
writeReport2 :: [Char] -> IO (ParseResult (IO ()))
writeReport2 name = do
x <- foobar
return $ do
y <- x
return $ do
z <- (execLaTeXT . docAndGraph) y
renderFile fileName z
where
fileName = name ++ ".tex"
main :: IO ()
main = join $ fromParseResult <$> writeReport2 "test"
Loading into GHCi:
$ stack ghci
io-action-nested-in-other-monads-not-executing-0.1.0.0: initial-build-steps (exe)
Configuring GHCi with the following packages: io-action-nested-in-other-monads-not-executing
Using main module: 1. Package `io-action-nested-in-other-monads-not-executing' component exe:io-action-nested-in-other-monads-not-executing with main-is file: /home/sven/dev/stackoverflow-questions/io-action-nested-in-other-monads-not-executing/src/Main.hs
GHCi, version 8.0.2: http://www.haskell.org/ghc/ :? for help
Loaded GHCi configuration from /home/sven/.ghc/ghci.conf
[1 of 1] Compiling Main ( /home/sven/dev/stackoverflow-questions/io-action-nested-in-other-monads-not-executing/src/Main.hs, interpreted )
Ok, modules loaded: Main.
Loaded GHCi configuration from /tmp/ghci22616/ghci-script
And running it:
λ main
Creates this file:
$ cat test.tex
\documentclass{article}\begin{document}[(" | HaskellExample Example File\n | Two examples are given below:\n\n >>> fib 10\n 55\n\n >>> putStrLn \"foo\\nbar\"\n foo\n bar ","fib :: Int -> Int"),("\n | This is a thing: ","fib = undefined"),("\n | This is a thing:\n","fibar :: String -> Float")]\end{document}%
I know it is not the scope of the question, but you could circumvent the nested IO if you want, by doinf this, for example:
writeReport3 :: [Char] -> IO ()
writeReport3 name = do
let fileName = name ++ ".tex"
x <- foobar
case x of
ParseOk y -> do
z <- execLaTeXT (docAndGraph y)
renderFile fileName z
ParseFailed _ _ ->
return ()
main :: IO ()
main = writeReport3 "test"
I just started learning Haskell and now got stuck in dealing with IO action.
Here's the code.
parseDnsMessage :: BG.BitGet DnsMessage
recQuery :: BS.ByteString -> String -> IO BS.ByteString
resolveName :: [Word8] -> [Word8] -> BS.ByteString -> String
resolveName qname name bstr = do
let newbstr = BSL.toStrict $ replace (BS.pack qname) (BS.pack name) bstr
retbstr <- recQuery newbstr (head rootServers4)
let msg = BG.runBitGet retbstr parseDnsMessage
case msg of
Right m -> (intercalate "." $ map show (rdata $ head $ answer $ m))
---Error Message---
Couldn't match expected type ‘[BSI.ByteString]’
with actual type ‘IO BSI.ByteString’
In a stmt of a 'do' block:
retbstr <- recQuery newbstr (head rootServers4)
In the expression:
do { let newbstr
= BSL.toStrict $ replace (BS.pack qname) (BS.pack name) bstr;
retbstr <- recQuery newbstr (head rootServers4);
let msg = BG.runBitGet retbstr parseDnsMessage;
case msg of {
Right m
-> (intercalate "." $ map show (rdata $ head $ answer $ m)) } }
I just want to retrieve BS.ByteString from the recQuery IO action.
How can I fix this?
The problem is your resolveName should return IO String, not String. This is because it is operating in the IO monad, i.e. you are chaining IO actions in it, so it must return IO.
I am learning Haskell, and having a great time. One of the things I especially enjoy is using the monad error types to propagate error conditions behind the scene in fmap or >>=. For example, in this code, I am using hoauth2 for an authenticated connection. It defines OAuth2Result using Either...
type OAuth2Result a = Either ByteString a -- from OAuth2
getEntries :: Manager -> AccessToken -> IO(OAuth2Result [Entry])
-- code omitted
filterResults :: [Entry] -> OAuth2Result [Entry]
filterResults = return $ filter hasUrl
printEntries :: [Entry] -> IO() -- What type can I use here?
printEntries Left l = -- code omitted
printEntries Right r = -- code omitted
main = do
entriesResult <- getEntries mgr token -- This is an OAuth2Result
let filtered = entriesResult >>= filterResults
printEntries filtered
The problem that I am having is when a function has IO like printEntries. In this case, I have to explicitly pattern match to do the error handling. I would sure love to be able to hide it somehow as I did with the filterResults call.
How can I do this?
Thanks!
Here's how to do it with runEitherT which requires some lifting and hoisting to get the types right:
import Control.Monad
import Control.Monad.Trans
import Control.Error
import Data.List (isInfixOf)
type Entry = String
type Result a = Either String a
sampleEntries = [ "good 1", "good 2", "good 3", "bad 4", "good 5", "bad 6", "good 7" ]
getEntries :: Int -> IO (Result [Entry])
getEntries n = if n >= 0 && n <= length sampleEntries
then return $ Right $ take n sampleEntries
else return $ Left $ "invalid n: " ++ show n
filterEntries :: [Entry] -> Result [Entry]
filterEntries ents = if all isGood ents
then Right $ ents
else Left "found a bad entry"
where isGood str = isInfixOf "good" str
printEntries :: [Entry] -> IO ()
printEntries ents = forM_ (zip [1..] ents) $ \(i,e) -> print (i,e)
doit n = do
ents <- (lift $ getEntries n) >>= hoistEither
filtered <- hoistEither $ filterEntries ents
lift $ printEntries filtered
main n = do result <- runEitherT $ doit n
case result of
Left e -> putStrLn $ "Error: " ++ e
Right _ -> putStrLn $ "no errors"
Note the following behavior:
main 100 fails because getEntries returns an error
main 4 fails because filterEntries returns an error
main 3 succeeds
First, because this is about a specific case, I haven't reduced the code at all, so it will be quite long, and in 2 parts (Helper module, and the main).
SpawnThreads in ConcurHelper takes a list of actions, forks them, and gets an MVar containing the result of the action. It them combines the results, and returns the resulting list. It works fine in certain cases, but blocks indefinitely on others.
If I give it a list of putStrLn actions, it executes them fine, then returns the resulting ()s (yes, I know running print commands on different threads at the same time is bad in most cases).
If I try running multiTest in Scanner though (which takes either scanPorts or scanAddresses, the scan range, and the number of threads to use; then splits the scan range over the threads, and passes the list of actions to SpawnThreads), it will block indefinitely. The odd thing is, according to the debug prompts scattered around ConcurHelper, on each thread, ForkIO is returning before the MVar is filled. This would make sense if it wasn't in a do block, but shouldn't the actions be performed sequentially? (I don't know if this is related to the problem or not; it's just something I noticed while attempting to debug it).
I've thought it out step by step, and if it's executing in the order laid out in spawnThreads, the following should happen:
An empty MVar should be created inside forkIOReturnMVar, and passed to mVarWrapAct.
mVarWrapAct should execute the action, and put the result in the MVar (this is where the problem seems to lie. "MVar filled" is never shown, suggesting the MVar is never put into)
getResults should then take from the resulting list of MVars, and return the results
If point #2 isn't the issue, I can see where the problem would be (and if it is the issue, I can't see why putMVar never executes. Inside the scanner module, the only real function of interest for this question is multiTest. I only included the rest so it could be run).
To do a simple test, you can run the following:
spawnThreads [putStrLn "Hello", putStrLn "World"] (should return [(),()])
multiTest (scanPorts "127.0.0.1") 1 (0,5) (Creates the MVar, hangs for a sec, then crashes with the aforementioned error)
Any help in understanding whats going on here would be appreciated. I can't see what the difference between the 2 use cases are.
Thank you
(And I'm using this atrocious exception handling system because IO errors don't give codes for specific network exceptions, so I've been left with parsing messages to find out what happened)
Main:
module Scanner where
import Network
import Network.Socket
import System.IO
import Control.Exception
import Control.Concurrent
import ConcurHelper
import Data.Maybe
import Data.Char
import NetHelp
data NetException = NetNoException | NetTimeOut | NetRefused | NetHostUnreach
| NetANotAvail | NetAccessDenied | NetAddrInUse
deriving (Show, Eq)
diffExcept :: Either SomeException Handle -> Either NetException Handle
diffExcept (Right h) = Right h
diffExcept (Left (SomeException m))
| err == "WSAETIMEDOUT" = Left NetTimeOut
| err == "WSAECONNREFUSED" = Left NetRefused
| err == "WSAEHOSTUNREACH" = Left NetHostUnreach
| err == "WSAEADDRNOTAVAIL" = Left NetANotAvail
| err == "WSAEACCESS" = Left NetAccessDenied
| err == "WSAEADDRINUSE" = Left NetAddrInUse
| otherwise = error $ show m
where
err = reverse . dropWhile (== ')') . reverse . dropWhile (/='W') $ show m
extJust :: Maybe a -> a
extJust (Just a) = a
selectJusts :: IO [Maybe a] -> IO [a]
selectJusts mayActs = do
mays <- mayActs; return . map extJust $ filter isJust mays
scanAddresses :: Int -> Int -> Int -> IO [String]
scanAddresses port minAddr maxAddr =
selectJusts $ mapM (\addr -> do
let sAddr = "192.168.1." ++ show addr
print $ "Trying " ++ sAddr ++ " " ++ show port
connection <- testConn sAddr port
if isJust connection
then do hClose $ extJust connection; return $ Just sAddr
else return Nothing) [minAddr..maxAddr]
scanPorts :: String -> Int -> Int -> IO [Int]
scanPorts addr minPort maxPort =
selectJusts $ mapM (\port -> do
--print $ "Trying " ++ addr ++ " " ++ show port
connection <- testConn addr port
if isJust connection
then do hClose $ extJust connection; return $ Just port
else return Nothing) [minPort..maxPort]
main :: IO ()
main = do
withSocketsDo $ do
putStrLn "Scan Addresses or Ports? (a/p)"
choice <- getLine
if (toLower $ head choice) == 'a'
then do
putStrLn "On what port?"
sPort <- getLine
addrs <- scanAddresses (read sPort :: Int) 0 255
print addrs
else do
putStrLn "At what address?"
address <- getLine
ports <- scanPorts address 0 9999
print ports
main
testConn :: HostName -> Int -> IO (Maybe Handle)
testConn host port = do
result <- try $ timedConnect 1 host port
let result' = diffExcept result
case result' of
Left e -> do putStrLn $ "\t" ++ show e; return Nothing
Right h -> return $ Just h
setPort :: AddrInfo -> Int -> AddrInfo
setPort addInf nPort = case addrAddress addInf of
(SockAddrInet _ host) -> addInf { addrAddress = (SockAddrInet (fromIntegral nPort) host)}
getHostAddress :: HostName -> Int -> IO SockAddr
getHostAddress host port = do
addrs <- getAddrInfo Nothing (Just host) Nothing
let adInfo = head addrs
newAdInfo = setPort adInfo port
return $ addrAddress newAdInfo
timedConnect :: Int -> HostName -> Int -> IO Handle
timedConnect time host port = do
s <- socket AF_INET Stream defaultProtocol
setSocketOption s RecvTimeOut time; setSocketOption s SendTimeOut time
addr <- getHostAddress host port
connect s addr
socketToHandle s ReadWriteMode
multiTest :: (Int -> Int -> IO a) -> Int -> (Int, Int) -> IO [a]
multiTest partAction threads (mi,ma) =
spawnThreads $ recDiv [mi,perThread..ma]
where
perThread = ((ma - mi) `div` threads) + 1
recDiv [] = []
recDiv (curN:restN) =
partAction (curN + 1) (head restN) : recDiv restN
Helper:
module ConcurHelper where
import Control.Concurrent
import System.IO
spawnThreads :: [IO a] -> IO [a]
spawnThreads actions = do
ms <- mapM (\act -> do m <- forkIOReturnMVar act; return m) actions
results <- getResults ms
return results
forkIOReturnMVar :: IO a -> IO (MVar a)
forkIOReturnMVar act = do
m <- newEmptyMVar
putStrLn "Created MVar"
forkIO $ mVarWrapAct act m
putStrLn "Fork returned"
return m
mVarWrapAct :: IO a -> MVar a -> IO ()
mVarWrapAct act m = do a <- act; putMVar m a; putStrLn "MVar filled"
getResults :: [MVar a] -> IO [a]
getResults mvars = do
unpacked <- mapM (\m -> do r <- takeMVar m; return r) mvars
putStrLn "MVar taken from"
return unpacked
Your forkIOReturnMVar isn't exception safe: whenever act throws, the MVar isn't going to be filled.
Minimal example
import ConcurHelper
main = spawnThreads [badOperation]
where badOperation = do
error "You're never going to put something in the MVar"
return True
As you can see, badOperation throws, and therefore the MVar won't get filled in mVarWrapAct.
Fix
Fill the MVar with an appropriate value if you encounter an exception. Since you cannot provide a default value for all possible types a, it's better to use MVar (Maybe a) or MVar (Either b a) as you already do in your network code.
In order to catch the exceptions, use one of the operations provided in Control.Exception. For example, you could use onException:
mVarWrapAct :: IO a -> MVar (Maybe a) -> IO ()
mVarWrapAct act m = do
onException (act >>= putMVar m . Just) (putMVar m Nothing)
putStrLn "MVar filled"
However, you might want to preserve the actual exception for more information. In this case you could simply use catch together with Either SomeException a :
mVarWrapAct :: IO a -> MVar (Either SomeException a) -> IO ()
mVarWrapAct act m = do
catch (act >>= putMVar m . Right) (putMVar m . Left)
putStrLn "MVar filled"