How to avoid boilerplate assignments like doesExist <- doesDirectoryExist path and case doesExist of ... within IO?
Is there a more idiomatic way than this?
import System.Directory
import System.Environment
main = do
path:_ <- getArgs
doesDirectoryExist path >>= cond
(putStrLn $ path ++ " Exists")
(putStrLn $ path ++ " Does not exist")
cond b c a = if a then b else c
LambdaCase is applicable here:
{-# LANGUAGE LambdaCase #-}
import System.Directory
import System.Environment
main = do
path:_ <- getArgs
doesDirectoryExist path >>= \case
True -> putStrLn $ path ++ " Exists"
_ -> putStrLn $ path ++ " Does not exist"
Or same with "if":
doesDirectoryExist path >>= \x ->
if x then (putStrLn "Exists") else putStrLn ("Does not")
Related
I want to use Twitch package to copy any javascript files in the "central" directory to the "back" and "front" directories. This is the code:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.List
( isPrefixOf
, tails
, findIndex
)
import System.Directory
( createDirectoryIfMissing
, removeDirectoryRecursive
, copyFile
)
import System.Directory.Recursive
( getSubdirsRecursive
, getFilesRecursive
)
import Twitch
( defaultMain
, (|>)
)
main :: IO ()
main = do
putStrLn "Haskell works <(^u^)>"
-- Copy central folder to back and front, and setup recopy when central changes
copyCentral
defaultMain $ do
"./central/**/*.js" |> copyFileToBackAndFront
copyCentral :: IO ()
copyCentral = do
createDirectoryIfMissing False "./back/src/central/"
removeDirectoryRecursive "./back/src/central"
createDirectoryIfMissing False "./front/src/central/"
removeDirectoryRecursive "./front/src/central"
centralFiles <- getFilesRecursive "./central/"
centralDirs <- getSubdirsRecursive "./central/"
mapM_ (\d -> createDirectoryIfMissing True $ "./back/src" ++ tail d) centralDirs
mapM_ (\d -> createDirectoryIfMissing True $ "./front/src" ++ tail d) centralDirs
mapM_ (\f -> copyFile f $ "./back/src" ++ tail f) centralFiles
mapM_ (\f -> copyFile f $ "./front/src" ++ tail f) centralFiles
copyFileToBackAndFront :: FilePath -> IO ()
copyFileToBackAndFront absolutePath =
maybe
(putStrLn "Error in the file path")
getRelativePathAndCopy
(findIndex (isPrefixOf "central") (tails absolutePath))
where
getRelativePathAndCopy n = do
let relativePath = drop n absolutePath
copyFile relativePath $ "./back/src/" ++ relativePath
copyFile relativePath $ "./front/src/" ++ relativePath
putStrLn $ "Copied file " ++ relativePath ++ " to back and front"
And surprisingly it works! But i get the putStrLn output 2 times:
Copied file central\models\Board\Board.js to back and front
Copied file central\models\Board\Board.js to back and front
And I suspect it may be because of the program running in 2 threads, because sometimes I get interlaced output:
CCooppiieedd ffiillee cceennttrraall\\mmooddeellss\\BBooaarrdd\\BBooaarrdd..jjss ttoo bbaacckk aanndd ffrroonntt
CopiCeodp ifeidl ef icleen tcreanlt\rmaold\emlosd\eBlosa\rBdo\aBroda\rBdo.ajrsd .tjos btaoc kb aacnkd afnrdo nftr
ont
Also this happends when i run cabal v2-repl, i just tried cabal v2-run myprogram & and it does not work at all :(
Any help with both issues please?
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"
This is an exercise to learn the StateT monad. The program implements the game Morra. The two players are the computer and a person. The state accumulates the score of the computer and player. The program works for one iteration of function morra. However I am at a loss how to loop it. I have tried a few things but nothing seems to work.
module Morra where
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class
import Data.Char (isDigit, digitToInt)
import System.Random (randomRIO)
import Control.Monad (when)
morra :: StateT (Int, Int) IO ()
morra = do
p <- liftIO getChar
when (isDigit p) $
do
let p' = digitToInt p
c <- liftIO $ randomRIO (1, 2)
liftIO $ putStrLn ['P',':',' ',p] --"P: " ++ p)
liftIO $ putStrLn ("C: " ++ show c)
(pt, ct) <- get
if even (c + p') then
do
liftIO $ putStrLn "Computer Wins"
put (pt, ct + 1)
else
do
liftIO $ putStrLn "Player Wins"
put (pt + 1, ct)
main :: IO ()
main = do
putStrLn "-- p is Player"
putStrLn "-- c is Computer"
putStrLn "-- Player is odds, Computer is evens."
fScore <- runStateT morra (0,0)
let personS = fst . snd $ fScore
compS = snd . snd $ fScore
putStrLn ("Person Score: " ++ show personS)
putStrLn ("Computer Score: " ++ show compS)
if personS > compS then
putStrLn "Winner is Person"
else
putStrLn "Winner is Computer"
You're 99% there. Just add main on a new line right after the last putStrLn, and main will call itself, effectively restarting the program.
A few tricks to simplify some things in your code:
Use execStateT:: StateT s m a -> s -> m s to take just the final state of the round. This way, you don't need to use the let bindings to extract the score, and can do it inline instead: (personS,compS) <- execStateT morra (0,0)
['P',':',' ',p] can be written as ("P: " ++ [p])
It's a matter of style and preference, but you can reduce a lot of the indentation and formatting whitespace by rearranging your ifs, elses and dos:
if condition
then do
doSomethingA
doSomethingB
else someFunction $ do
doSomethingElseA
doSomethingElseB
Overall, nice job :)
I replaced p <- liftIO getChar with p <- liftIO getLine and made a few other minor changes to allow for the fact that p is now a String rather than a Char. Now it works. Seems that it has something to do with Windows as it works using getChar on linux. This is the final code:
module Morra where
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class
import Data.Char (isDigit, digitToInt)
import System.Random (randomRIO)
import Control.Monad (when)
morra :: StateT (Int, Int) IO ()
morra = do
p <- liftIO getLine
let p1 = head p
when (isDigit p1) $ do
let p' = digitToInt p1
c <- liftIO $ randomRIO (1, 2)
liftIO $ putStrLn ("P: " ++ p)
liftIO $ putStrLn ("C: " ++ show c)
(pt, ct) <- get
if even (c + p') then do
liftIO $ putStrLn "Computer Wins"
put (pt, ct + 1)
else do
liftIO $ putStrLn "Player Wins"
put (pt + 1, ct)
morra
main :: IO ()
main = do
putStrLn "-- p is Player"
putStrLn "-- c is Computer"
putStrLn "-- Player is odds, Computer is evens."
(personS,compS) <- execStateT morra (0,0)
putStrLn ("Person Score: " ++ show personS)
putStrLn ("Computer Score: " ++ show compS)
if personS == compS then
putStrLn "No Winner"
else if personS > compS then
putStrLn "Winner is Person"
else
putStrLn "Winner is Computer"
Can anyone help me "translate" the below from happs to happstack:
module Main where
import HAppS.Server.AlternativeHTTP
import HAppS.Server.HTTP.AltFileServe
import Control.Monad.State
import Numeric
import Contracts
instance FromData ExContr where
fromData = do c <- look "contract"
arg1 <- look "arg1"
arg2 <- look "arg2"
img <- look "image"
return $ ExContr (c, map fst $ readFloat arg1
++ readFloat arg2, read img)
main :: IO ()
main = do simpleHTTP [dir "contractEx"
[withData $ \(ExContr t) ->
[anyRequest $ liftIO $ liftM toResponse =<< renderEx (ExContr t)]
,anyRequest $ ok $ toResponse renderExDefault]
,fileServe ["Contracts.html"] "public" -- fileserving
]
Contracts.hs contains:
newtype ExContr = ExContr (String, [Double], Bool) deriving (Read,Show,Eq)
renderEx :: ExContr -> IO Html
renderEx exSpec#(ExContr (contractId, args, lattice)) =
let pr = evalEx exSpec
expValChart = if contractId == "probs" then noHtml -- expected value is meaningless for the probabilities it relies on
else h3 << "Expected value" +++ image ! [src (chartUrl $ expectedValuePr pr)]
imageType = "png"
in if useLatticeImage exSpec
then do baseName <- mkUniqueName baseDotFilename
exitCode <- latticeImage pr (webPath ++ tmpImgPath ++ baseName) imageType
let pageContents =
case exitCode of
ExitSuccess -> renderExampleForm exSpec (image ! [src latticeUrl, border 1]) expValChart
where latticeUrl = "/" ++ tmpImgPath ++ baseName ++ "." ++ imageType
_ -> p << "renderEx: error generating lattice image"
return $ renderExamplePage pageContents
else return $ renderExamplePage $ renderExampleForm exSpec (prToTable pr) expValChart
renderExDefault = renderExamplePage $
renderExampleForm (ExContr ("zcb", [fromIntegral t1Horizon, 10], True))
noHtml noHtml
Alternatively I would like to understand how to install an old version of HappS compatible with the above code. Needless to say I am very new to Haskell.
This should work, assuming your ExContr type and renderEx functions that you did not supply in your code are similar to what I have here. I cannot actually run your code to ensure that it behaves the same.
module Main where
import Control.Monad
import Control.Monad.Trans (liftIO)
import Happstack.Server.Internal.Monads (anyRequest)
import Happstack.Server.SimpleHTTP
import Happstack.Server.FileServe
import Numeric
-- data ExContr = ExContr (String, [Double], String)
-- renderEx :: ExContr -> IO String
-- renderEx = undefined
instance FromData ExContr where
fromData = do c <- look "contract"
arg1 <- look "arg1"
arg2 <- look "arg2"
img <- look "image"
return $ ExContr (c, map fst $ readFloat arg1
++ readFloat arg2, read img)
main :: IO ()
main = do
simpleHTTP (nullConf { port = 80 }) $ msum [
dir "contractEx" $ withData $ \(ExContr t) -> msum $ [
anyRequest $ fmap toResponse $ liftIO $ renderEx (ExContr t)
, anyRequest $ ok $ toResponse renderExDefault
]
, serveDirectory DisableBrowsing ["Contracts.html"] "public"
]
Edited: forgot the renderExDefault line.
I have an AST representing a haskell program and a bitvector/bool list representing the presence of strictness annotations on Patterns in order.For example, 1000 represents a program with 4 Pats where the first one is a BangPat. Is there any way that I can turn on and off the annotations in the AST according to the list?
-- EDIT: further clarify what I want editBang to do
Based on user5042's answer:
Simple.hs :=
main = do
case args of
[] -> error "blah"
[!x] -> putStrLn "one"
(!x : xs) -> putStrLn "many"
And I want editBang "Simple.hs" [True, True, True, True] to produce
main = do
case args of
[] -> error "blah"
[!x] -> putStrLn "one"
(!(!x : !xs)) -> putStrLn "many"
Given that above are the only 4 places that ! can appear
As a first step, here's how to use transformBi:
import Data.Data
import Control.Monad
import Data.Generics.Uniplate.Data
import Language.Haskell.Exts
import Text.Show.Pretty (ppShow)
changeNames x = transformBi change x
where change (Ident str) = Ident ("foo_" ++ str)
change x = x
test2 = do
content <- readFile "Simple.hs"
case parseModule content of
ParseFailed _ e -> error e
ParseOk a -> do
let a' = changeNames a
putStrLn $ ppShow a'
The changeNames function finds all occurrences of a Ident s and replaces it with Ident ("foo_"++s) in the source tree.
There is a monadic version called transformBiM which allows the replacement function to be monadic which would allow you to consume elements from your list of Bools as you found bang patterns.
Here is a complete working example:
import Control.Monad
import Data.Generics.Uniplate.Data
import Language.Haskell.Exts
import Text.Show.Pretty (ppShow)
import Control.Monad.State.Strict
parseHaskell path = do
content <- readFile path
let mode = ParseMode path Haskell2010 [EnableExtension BangPatterns] False False Nothing
case parseModuleWithMode mode content of
ParseFailed _ e -> error $ path ++ ": " ++ e
ParseOk a -> return a
changeBangs bools x = runState (transformBiM go x) bools
where go pp#(PBangPat p) = do
(b:bs) <- get
put bs
if b
then return p
else return pp
go x = return x
test = do
a <- parseHaskell "Simple.hs"
putStrLn $ unlines . map ("before: " ++) . lines $ ppShow a
let a' = changeBangs [True,False] a
putStrLn $ unlines . map ("after : " ++) . lines $ ppShow a'
You might also look into using rewriteBiM.
The file Simple.hs:
main = do
case args of
[] -> error "blah"
[!x] -> putStrLn "one"
(!x : xs) -> putStrLn "many"