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.
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 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"
I'd like to pass an integer as a CLI argument to a Haskell program that makes use of QuickCheck / monadicIO. That integer is going to be used inside the assert to make the tests customizable.
The problem is that once I parse the integer value in main, I don't know how to pass it inside of the monadicIO call without using something as ugly as an IORef. I would think that an elegant solution might be the Reader monad, but I couldn't find a solution to make it work, seen as quickCheck is rigid in its arguments.
Any ideas?
Later Edit 1: As requested, I'm attaching the actual code I'm trying this on, and failing. The commented-out lines represent my failed attempt. Background: the test suite is intended to exercise a very simple remote endpoint that computes the SHA512 of the randomized input generated by QuickCheck. The remote endpoint is Python/Flask based.
Later Edit 2 in response to #user2407038: I could make propHasExpectedLengthCeiling take an additional argument of type Int, but quickCheck would generate random values for it, and that's not what I want happening. My goal is to use the maxSegmentLengthCeiling that I'm taking in from the command-line arguments and use it in let testPassed = actualMaxSegmentLength <= maxSegmentLengthCeiling inside of the monadicIO block. Right now maxSegmentLengthCeiling is specified as a top-level value, which means I have to recompile the code every time I change the value. I don't yet have any code that involves IORef because that's a last resort and the essence of my question is how to avoid going the IORef route.
import qualified Data.ByteString.Lazy.Char8 as LC
import Control.Applicative ( (<$>) )
import Data.Function ( on )
import Data.List ( groupBy )
import Data.Char ( isDigit )
--import Safe ( headMay
-- , readMay
-- )
--import System.Environment ( getArgs )
import Network.HTTP.Conduit ( simpleHttp )
import Test.QuickCheck ( Arbitrary
, Property
, arbitrary
, choose
, frequency
, quickCheckWith
, stdArgs
, vectorOf
)
import Test.QuickCheck.Test ( Args
, maxSuccess
)
import Test.QuickCheck.Monadic ( assert
, monadicIO
, run
)
newtype CustomInput = MkCustomInput String deriving Show
instance Arbitrary CustomInput where
arbitrary =
let
genCustomInput = vectorOf 20
$ frequency [ (26, choose ('0','9'))
, (10, choose ('a','z'))
]
in
MkCustomInput <$> genCustomInput
maxSegmentLengthCeiling :: Int
maxSegmentLengthCeiling = 22
urlPrefix :: String
urlPrefix = "http://192.168.2.3:5000/sha512sum/"
propHasExpectedLengthCeiling :: CustomInput -> Property
propHasExpectedLengthCeiling (MkCustomInput input) = monadicIO $ do
testPassed <- run $ do
response <- simpleHttp $ urlPrefix ++ input
let stringResponse = LC.unpack response
let brokenDownStringResponse = groupBy ( (==) `on` isDigit ) stringResponse
let actualMaxSegmentLength = maximum $ map length brokenDownStringResponse
let testPassed = actualMaxSegmentLength <= maxSegmentLengthCeiling
putStrLn ""
putStrLn ""
putStrLn $ "Input: " ++ input
putStrLn $ "Control sum: " ++ stringResponse
putStrLn $ "Breakdown: " ++ show brokenDownStringResponse
putStrLn $ "Max. length: " ++ show actualMaxSegmentLength
putStrLn $ "Ceiling: " ++ show maxSegmentLengthCeiling
putStrLn $ "Test result: " ++ if testPassed then "Pass" else "Fail"
putStrLn ""
putStrLn ""
return testPassed
assert $ testPassed
customArgs :: Args
customArgs = stdArgs { maxSuccess = 1000000 }
--readMayAsInt :: String -> Maybe Int
--readMayAsInt = readMay
main :: IO ()
main =
--main = do
-- cliArgs <- getArgs
-- let ceilingInputMay = headMay cliArgs >>= readMayAsInt
-- maxSegmentLengthCeiling <- case ceilingInputMay of
-- (Just lengthCeiling) -> return lengthCeiling
-- Nothing -> error "No valid number given"
quickCheckWith
customArgs
propHasExpectedLengthCeiling
Make maxSegmentLengthCeiling a parameter to propHasExpectedLengthCeiling :
propHasExpectedLengthCeiling :: Int -> CustomInput -> Property
and invoke it as
main = do
[n] <- getArgs
quickCheckWith customArgs (propHasExpectedLengthCeiling (read n))
Closed. This question is off-topic. It is not currently accepting answers.
Want to improve this question? Update the question so it's on-topic for Stack Overflow.
Closed 11 years ago.
Improve this question
Must say I find programming in Haskell to require much more cognitive intensity than any other language I've tried. I'm not certain I care about lazy evaluation or monads very much, but I do appreciate certain functional aspects, static type checking and not needing a huge VM to run.
I've been writing a short program to rename images based on EXIF and now have something that works. I'd like someone Haskell expert opinions on the overall structure of the source code in terms of what I've done right/wrong, and how I might improve and make the code more succinct. I won't bother posting the entire program but a lot of the overall structure is below. Appreciate it.
import Control.Applicative
import Control.Monad.Error
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Data.Time.Format
import Data.Time.LocalTime
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.FilePath
import System.Locale
import System.IO.Error
import Text.Printf
import Album.Utils
import Album.Exif
import Album.Error
-- -----------------------------------------------------------------------
-- Main
main = do
r <- try main0
case r of
Left err -> do
printf "Error type: %s\n" $ (show $ ioeGetErrorType err)
printf "Error string: %s\n" $ (ioeGetErrorString err)
printf "Error filename: %s\n" $ (maybe "None" id $ ioeGetFileName err)
printf "Error handle: %s\n" $ (maybe "None" show $ ioeGetHandle err)
Right _ -> return ()
-- Process arguments
main0 = do
args <- getArgs
case processArgs args desc of
(True, _, usage) -> showUsage usage
(False, (flags, fns, []), usage) -> do
rv <- runErrorT $ main1 flags fns
either (\e -> showErrs [show e] usage) (const $ return ()) rv
(False, (_, _, errs), usage) -> showErrs errs usage
where
desc = "Rename and catalog media.\n" ++
"Usage: album -n <albumname> <options> <media files>\n"
-- Sanity check
main1 flags fns = do
-- Check name
albName <- maybe (throwError AlbumNameError) return $ albumName flags
-- Check for duplicate media
let dups = nub $ fns \\ nub fns
unless (null dups) $ throwError $ MediaDuplicateError dups
-- Check for valid filenames
(haves, havenots) <- liftIO $ filesExist fns
unless (null havenots) $ throwError $ MediaNotFoundError havenots
when (null haves) $ throwError MediaNotSpecifiedError
-- Check exiftool existence
tool0 <- liftIO $ findExecutable "exiftool"
tool <- maybe (throwError ExifToolNotFoundError) return tool0
-- Get EXIF attributes
exifs0 <- liftIO $ getExifs tool fns
exifs <- either (throwError . ExifParseError) return exifs0
-- Check for exiftool errors
let bads = findExifs "ExifTool:Error" exifs
unless (null bads) $ throwError $ MediaBadError $ map fst bads
-- Check for timestamps
let infos0 = map (\(n,e) -> (n, exifToDateTime e)) exifs
let nodates = filter (isNothing . snd) infos0
unless (null nodates) $ throwError $ MediaDateTimeTagError $ map fst nodates
let infos = map (\(n,Just dt) -> (n,dt)) infos0
main2 albName infos
-- Do renames
main2 albName infos = do
-- Album folder name
let mints = minimum $ map snd infos
let mintsiso = formatTime defaultTimeLocale "%Y%m%d" mints
let albFolder = printf "%s - %s" mintsiso albName
-- Get list of existing media
albExist <- liftIO $ doesDirectoryExist albFolder
(albCreate, existing) <- case albExist of
False -> return (True, [])
True -> do
e <- liftIO $ filter ((/= ".") . nub) <$> getDirectoryContents albFolder
return (False, e)
-- Rename list
let rens0 = mediaNames albName infos existing
let rens1 = map (\(a,b) -> (a, combine albFolder b)) rens0
let len = maximum $ map (length . fst) rens1
if albCreate
then do
liftIO $ printf "Creating folder: %s\n" albFolder
liftIO $ createDirectory albFolder
else
return ()
forM_ rens1 $ \(oldf, newf) -> do
liftIO $ printf "%*s >>> %s\n" len oldf newf
liftIO $ renameFile oldf newf
return ()
showErrs errs usage = do
putStrLn $ concatMap ("Error: " ++ ) errs
return ()
showUsage usage = do
putStrLn usage
return ()
-- -----------------------------------------------------------------------
-- Rename
mediaNames albName infos existing = go existing (map cands infos)
where
go es [] = []
go es ((fn,cs):css) = let p = unused cs es in (fn,p):go (p:es) css
unused cs es = fromJust $ find (`notElem` es) cs
cands (fn,dt) = (fn, map (++ ext) (pref:alts))
where
pref = printf "%s - %s" (ft dt) albName
ft dt = formatTime defaultTimeLocale "%Y%m%dT%H%M%S" dt
alts = map (printf "%s (%02d)" pref) ([1..] :: [Int])
ext = map toLower (takeExtension fn)
-- -----------------------------------------------------------------------
-- Arguments
data Option = OptionAlbumName String
| OptionHelp
deriving (Eq, Show)
processArgs args desc = (elem OptionHelp flags, opts, usage)
where
opts#(flags, fns, errs) = getOpt RequireOrder conf args
usage = usageInfo desc conf
conf = [
Option "n" ["name"] (ReqArg OptionAlbumName "NAME") "Album name",
Option "h" ["help"] (NoArg OptionHelp) "Help"]
albumName (OptionAlbumName n:xs) = Just n
albumName (x:xs) = albumName xs
albumName [] = Nothing