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"
Related
I am scraping https://books.toscrape.com using Haskell's Scalpel library. Here's my code so far:
import Text.HTML.Scalpel
import Data.List.Split (splitOn)
import Data.List (sortBy)
import Control.Monad (liftM2)
data Entry = Entry {entName :: String
, entPrice :: Float
, entRate :: Int
} deriving Eq
instance Show Entry where
show (Entry n p r) = "Name: " ++ n ++ "\nPrice: " ++ show p ++ "\nRating: " ++ show r ++ "/5\n"
entries :: Maybe [Entry]
entries = Just []
scrapePage :: Int -> IO ()
scrapePage num = do
items <- scrapeURL ("https://books.toscrape.com/catalogue/page-" ++ show num ++ ".html") allItems
let sortedItems = items >>= Just . sortBy (\(Entry _ a _) (Entry _ b _) -> compare a b)
>>= Just . filter (\(Entry _ _ r) -> r == 5)
maybe (return ()) (mapM_ print) sortedItems
allItems :: Scraper String [Entry]
allItems = chroots ("article" #: [hasClass "product_pod"]) $ do
p <- text $ "p" #: [hasClass "price_color"]
t <- attr "href" $ "a"
star <- attr "class" $ "p" #: [hasClass "star-rating"]
let fp = read $ flip (!!) 1 $ splitOn "£" p
let fStar = drop 12 star
return $ Entry t fp $ r fStar
where
r f = case f of
"One" -> 1
"Two" -> 2
"Three" -> 3
"Four" -> 4
"Five" -> 5
main :: IO ()
main = mapM_ scrapePage [1..10]
Basically, allItems scrapes for each book's title, price and rating, does some formatting for price to get a float, and returns it as a type Entry. scrapePage takes a number corresponding to the result page number, scrapes that page to get IO (Maybe [Entry]), formats it - in this case, to filter for 5-star books and order by price - and prints each Entry. main performs scrapePage over pages 1 to 10.
The problem I've run into is that my code scrapes, filters and sorts each page, whereas I want to scrape all the pages then filter and sort.
What worked for two pages (in GHCi) was:
i <- scrapeURL ("https://books.toscrape.com/catalogue/page-1.html") allItems
j <- scrapeURL ("https://books.toscrape.com/catalogue/page-2.html") allItems
liftM2 (++) i j
This returns a list composed of page 1 and 2's results that I could then print, but I don't know how to implement this for all 50 result pages. Help would be appreciated.
Just return the entry list without any processing (or you can do filtering in this stage)
-- no error handling
scrapePage :: Int -> IO [Entry]
scrapePage num =
concat . maybeToList <$> scrapeURL ("https://books.toscrape.com/catalogue/page-" ++ show num ++ ".html") allItems
Then you can process them later together
process = filter (\e -> entRate e == 5) . sortOn entPrice
main = do
entries <- concat <$> mapM scrapePage [1 .. 10]
print $ process entries
Moreover you can easily make your code concurrent with mapConcurrently from async package
main = do
entries <- concat <$> mapConcurrently scrapePage [1 .. 20]
print $ process entries
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 make a function which read file and removes in every line all the words that were encountered earlier in the same line.
{-# OPTIONS_GHC -Wall #-}
module Main where
import System.Environment
import System.IO()
main :: IO ()
main = do args <- getArgs
if (length args > 0) then do
f <- get args
putStrLn (seqWord $ head f)
else do
f <- getContents
putStrLn (seqWord f)
get :: [String] -> IO[String]
get [] = return []
get (file:xs) = do
contents <- readFile file
fs <- get xs
return (contents:fs)
seqWord :: String -> String
seqWord s = show (map (filterWord . words) (lines s))
filterWord :: [String] -> [String]
filterWord [] = []
filterWord (x:xs) = x : filterWord (filter(/=x) xs)
In answer I have list of lists, like this
[["1","12","5","8","13","145","85"],["546","822","1","12","58","8","9"]]
Please, help me fix this problem. Thank you
Use the unwords function to undo the effect of words. You may also want to replace show with unlines.
seqWord s = unlines (map (unwords . filterWord . words) (lines s))
I have a module called EditorTest in a similarly-named file.
It imports some modules. It also has some declarations in it, as any Haskell module does.
I'd like to programmatically obtain a list of the top level available declarations within the context of that module.
What I have so far is a way to get the top level local declarations of this module only, by using hint. That's fine, and I figure I could recurse the imports (and so on into those modules, etc), collecting a list of them, then use hint to grab all the available declaration names... but if possible, I'm after an easier way to find the available declarations in a given module. I figure Haskell's API should have some way to do that.
Is there such a thing?
Self-answering because it's been a while and I spiked out a proof of concept ages ago, so I'll put it here for others, even if it is fairly messy.
So, assuming we have this file as TestModule.hs:
module TestModule (g, h) where
import Data.List as L
f = head
g = f [f]
h = L.map
Then the following code can be used to show how we can pull out the top level declarations and use them by using Hint's Language.Haskell.Interpreter module and the Language.Haskell.Exts.SrcLoc module from the haskell-src-exts package:
import Data.List
import Control.Monad
import qualified Language.Haskell.Interpreter as I
import Language.Haskell.Interpreter (Interpreter, GhcError(..), InterpreterError(..))
import qualified Language.Haskell.Exts as H
import Language.Haskell.Exts.SrcLoc
main :: IO ()
main = do r <- I.runInterpreter interpreterTest
case r of
Left err -> putStrLn $ errorString err
Right () -> return ()
errorString :: InterpreterError -> String
errorString (WontCompile es) = intercalate "\n" (header : map unbox es)
where
header = "ERROR: Won't compile:"
unbox (GhcError e) = e
errorString e = show e
p :: String -> Interpreter ()
p = I.liftIO . putStrLn
emptyLine :: Interpreter ()
emptyLine = p ""
interpreterTest :: Interpreter ()
interpreterTest =
do
p "Finding out what the module exports are."
p "To do this, we grab the text of the src/TestModule.hs"
moduleContents <- I.liftIO . readFile $ "src/TestModule.hs"
emptyLine
p "Next, we find what the import module names are, so we can load them"
p "To do that, we'll parse the contents of src/TestModule.hs as AST"
let
parseResult = H.parseModule moduleContents
parsedModuleDeclE =
case parseResult of
H.ParseOk parsed -> Right parsed
H.ParseFailed _ errorReason -> Left errorReason
(moduleDeclarations, moduleImports) =
case parsedModuleDeclE of
Left _ ->
([], [])
Right (H.Module _ _ _ _ _ importDecls decls) -> (decls, importDecls)
p $ show moduleImports
emptyLine
p "Now we can pull the module names out of the ImportDecl values:"
let
moduleNames =
do
H.ModuleName s <- fmap H.importModule moduleImports
return s
p $ show moduleNames
emptyLine
p "After this we can obtain a list of the module exports for each of these modules and join them together:"
I.loadModules ["src/TestModule.hs"]
I.setTopLevelModules ["TestModule"]
topLevelImportDecls <- fmap concat $ mapM I.getModuleExports moduleNames
-- p $ show $ do { I.Fun f <- topLevelImportDecls ; return f } -- filter for functions only
p $ show $ fmap I.name topLevelImportDecls
emptyLine
p "Then, we can get the top level declarations of the initial module and add them, too:"
-- p $ show moduleDeclarations -- AST in haskell types
let
localDeclaractions =
do
(H.PatBind _ (H.PVar (H.Ident declName)) _ _) <- moduleDeclarations
return declName
availableDeclarations =
localDeclaractions ++ fmap I.name topLevelImportDecls
p $ show localDeclaractions
emptyLine
p "Finally, we have our big list:"
p $ show availableDeclarations
emptyLine
p "Now, what about we get all of their types, just for fun?"
typesOfAll <- sequence $ fmap (\n -> fmap ((n ++ " :: ") ++) (I.typeOf n)) availableDeclarations
p $ Data.List.intercalate "\n" typesOfAll
return ()
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.