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?
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"
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'm having trouble directing flow though a pipeline with haskell-pipes. Basically, I analyze a bunch of files and then I have to either
print results to the terminal in a human-friendly way
encode results to JSON
The chosen path depends upon a command line option.
In the second case, I have to output an opening bracket, then every incoming value followed by a comma and then a closing bracket. Currently insertCommas never terminates, so the closing bracket is never outputted.
import Pipes
import Data.ByteString.Lazy as B
import Data.Aeson (encode)
insertCommas :: Consumer B.ByteString IO ()
insertCommas = do
first <- await
lift $ B.putStr first
for cat $ \obj -> lift $ do
putStr ","
B.putStr obj
jsonExporter :: Consumer (FilePath, AnalysisResult) IO ()
jsonExporter = do
lift $ putStr "["
P.map encode >-> insertCommas
lift $ putStr "]"
exportStream :: Config -> Consumer (FilePath, AnalysisResult) IO ()
exportStream conf =
case outputMode conf of
JSON -> jsonExporter
_ -> P.map (export conf) >-> P.stdoutLn
main :: IO ()
main = do
-- The first two lines are Docopt stuff, not relevant
args <- parseArgsOrExit patterns =<< getArgs
ins <- allFiles $ args `getAllArgs` argument "paths"
let conf = readConfig args
runEffect $ each ins
>-> P.mapM analyze
>-> P.map (filterResults conf)
>-> P.filter filterNulls
>-> exportStream conf
AFAIK a Consumer cannot detect the end of a stream. In order to do that you need to use a Pipes.Parser and invert the control.
Here is a Parser which inserts commas between String elements:
import Pipes
import qualified Pipes.Prelude as P
import Pipes.Parse (draw, evalStateT)
commify = do
lift $ putStrLn "["
m1 <- draw
case m1 of
Nothing -> lift $ putStrLn "]"
Just x1 -> do
lift $ putStrLn x1
let loop = do mx <- draw
case mx of
Nothing -> lift $ putStrLn "]"
Just x -> lift (putStr "," >> putStrLn x) >> loop
loop
test1 = evalStateT commify ( mapM_ yield (words "this is a test") )
test2 = evalStateT commify P.stdinLn
To handle the different output formats I would probably make both formats a Parser:
exportParser = do
mx <- draw
case mx of
Nothing -> return ()
Just x -> (lift $ putStrLn $ export x) >> exportParser
and then:
let parser = case outputMode of
JSON -> commify
_ -> exportParser
evalStateT parser (P.mapM analyze
>-> P.map (filterResults conf)
>-> P.filter filterNulls)
There is probably a slicker way to write exportParser in terms of foldAllM. You can also use the MaybeT transformer to more succinctly write the commify parser. I've written both out explicitly to make them easier to understand.
I think you should 'commify' with pipes-group. It has an intercalates, but not an intersperse, but it's not a big deal to write. You should stay away from the Consumer end, I think, for this sort of problem.
{-#LANGUAGE OverloadedStrings #-}
import Pipes
import qualified Pipes.Prelude as P
import qualified Data.ByteString.Lazy.Char8 as B
import Pipes.Group
import Lens.Simple -- or Control.Lens or Lens.Micro or anything with view/^.
import System.Environment
intersperse_ :: Monad m => a -> Producer a m r -> Producer a m r
intersperse_ a producer = intercalates (yield a) (producer ^. chunksOf 1)
main = do
args <- getArgs
let op prod = case args of
"json":_ -> yield "[" *> intersperse_ "," prod <* yield "]"
_ -> intersperse_ " " prod
runEffect $ op producer >-> P.mapM_ B.putStr
putStrLn ""
where
producer = mapM_ yield (B.words "this is a test")
which give me this
>>> :main json
[this,is,a,test]
>>> :main ---
this is a test
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"
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")