I have this piece of code and it works perfectly fine. It toggles some styles on the text input field depending on the field value.
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = divClass "form-group" $ do
let errorState = "style" =: "border-color: red"
validState = "style" =: "border-color: green"
rec n <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
& textInputConfig_attributes .~ attrs
let result = fmap (readMay . unpack) $ _textInput_value n
attrs = fmap (maybe errorState (const validState)) result
return result
I ran into some problems making the parent element dynamic. I'd like to toggle the styles on the parent element of text input. I'd like to write something like but failed!
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = do
rec
dynAttrs <- -- reference to textInput
elDynAttr "div" dynAttrs $ do
n <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
...
Thanks for helping out!
Here is a little program where the attributes (align right or left) of the parent element depend on the state of a child element:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
import Reflex.Dom
import qualified Data.Text as T
import Safe
main :: IO ()
main = mainWidget bodyElement
bodyElement :: MonadWidget t m => m ()
bodyElement = el "div" $ do
el "h2" $ text "Dynamic parent element"
numberInput
return ()
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = do
rec
let errorState = ("align" :: T.Text) =: "right"
validState = "align" =: "left"
let result = fmap (readMay . T.unpack) $ _textInput_value n
attrs = fmap (maybe errorState (const validState)) result
n <- elDynAttr "div" attrs $ do
n1 <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
text "Some additional control"
return n1
return result
As user user2407038 mentions, we have to return the numeric text element from an inner scope to the outer scope. Then we can use recursive do to access the element we define later in the program.
As soon as you type a letter into the numeric field, it will jump to the right.
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
With IHP (the haskell web framework) I created a web application. Now I want to create a IHP Script to load some external data into my database. However I'm getting a lot of import conflicts from the Prelude, but not the types I expected.
#!/usr/bin/env run-script
module Application.Script.DataLoader where
import Application.Script.Prelude hiding (decode, pack, (.:))
import qualified Data.ByteString.Lazy as BL
import Data.Csv
import Data.Text (pack)
import qualified Data.Vector as V
import Control.Monad (mzero)
instance FromNamedRecord Product where
parseNamedRecord r = Product def <$> r .: "title" <*> r .: "price" <*> r .: "category" <*> pure def
run :: Script
run = do
csvData <- BL.readFile "~/tender/data/Boiler-en-kookkraan_Boiler.csv"
case decodeByName csvData of
Left err -> putStrLn $ pack err
Right (_, v) -> V.forM_ v $ \ p ->
putStrLn $ (get #title p) ++ ", " ++ show (get #price p) ++ " euro"
Where my Product schema looks like this:
CREATE TABLE products (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
title TEXT NOT NULL,
price DOUBLE PRECISION NOT NULL,
category TEXT NOT NULL
);
Is there a way to use the types I created as a Data object to e.g. read my csv to?
[Updated output]
Application/Script/DataLoader.hs:12:26: error:
• Couldn't match type ‘MetaBag -> Product' a1’
with ‘Product' (QueryBuilder ProjectProduct)’
Expected type: Parser Product
Actual type: Parser (MetaBag -> Product' a1)
• In the expression:
Product def <$> r .: "title" <*> r .: "price" <*> r .: "category"
<*> pure def
In an equation for ‘parseNamedRecord’:
parseNamedRecord r
= Product def <$> r .: "title" <*> r .: "price" <*> r .: "category"
<*> pure def
In the instance declaration for ‘FromNamedRecord Product’
|
12 | parseNamedRecord r = Product def <$> r .: "title" <*> r .: "price" <*> r .: "category" <*> pure def
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
[Solved, all credits to the help of #mpscholten]
#!/usr/bin/env run-script
module Application.Script.DataLoader where
import Application.Script.Prelude hiding (decode, pack, (.:))
import qualified Data.ByteString.Lazy as BL
import Data.Csv
import Data.Text (pack)
import qualified Data.Vector as V
import Control.Monad (mzero)
parseProduct :: NamedRecord -> Parser Product
parseProduct r = do
title <- r .: "title"
price <- r .: "price"
category <- r .: "category"
newRecord #Product
|> set #title title
|> set #price price
|> set #category category
|> pure
run :: Script
run = do
csvData <- BL.readFile "data/Boiler-en-kookkraan_Boiler.csv"
case decodeByNameWithP parseProduct defaultDecodeOptions csvData of
Left err -> putStrLn $ pack err
Right (_, v) -> V.forM_ v $ \ p ->
putStrLn $ (get #title p) ++ ", " ++ show (get #price p) ++ " euro"
Inside the FromNamedRecord instance you are missing two fields: id and meta. The id field is the first field of the record. The meta field is a hidden field used by IHP to keep track of validation errors. It's always the last field of a record.
The easiest way to solve this is to use newRecord and write out the code in a more explicit way:
instance FromNamedRecord Product where
parseNamedRecord r = do
title <- r .: "title"
price <- r .: "price"
category <- r .: "category"
newRecord #Product
|> set #title title
|> set #price price
|> set #category category
|> pure
For the error "Ambiguous occurrence ‘title’" try to use the get function instead of using the normal haskell accessor function:
putStrLn $ (get #title p) ++ ", " ++ show (get #price p) ++ " euro"
Can you maybe share what errors you get exactly? Your desired product type should be in Generated.Types which intern is loaded by Application.Script.Prelude.
I think you might have two models that both have the field title. In haskell fields are functions and they may not be used twice.
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 ()
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'm trying to use CPS to simplify control-flow implementation in my Python interpreter. Specifically, when implementing return/break/continue, I have to store state and unwind manually, which is tedious. I've read that it's extraordinarily tricky to implement exception handling in this way. What I want is for each eval function to be able to direct control flow to either the next instruction, or to a different instruction entirely.
Some people with more experience than me suggested looking into CPS as a way to deal with this properly. I really like how it simplifies control flow in the interpreter, but I'm not sure how much I need to actually do in order to accomplish this.
Do I need to run a CPS transform on the AST? Should I lower this AST into a lower-level IR that is smaller and then transform that?
Do I need to update the evaluator to accept the success continuation everywhere? (I'm assuming so).
I think I generally understand the CPS transform: the goal is to thread the continuation through the entire AST, including all expressions.
I'm also a bit confused where the Cont monad fits in here, as the host language is Haskell.
Edit: here's a condensed version of the AST in question. It is a 1-1 mapping of Python statements, expressions, and built-in values.
data Statement
= Assignment Expression Expression
| Expression Expression
| Break
| While Expression [Statement]
data Expression
| Attribute Expression String
| Constant Value
data Value
= String String
| Int Integer
| None
To evaluate statements, I use eval:
eval (Assignment (Variable var) expr) = do
value <- evalExpr expr
updateSymbol var value
eval (Expression e) = do
_ <- evalExpr e
return ()
To evaluate expressions, I use evalExpr:
evalExpr (Attribute target name) = do
receiver <- evalExpr target
attribute <- getAttr name receiver
case attribute of
Just v -> return v
Nothing -> fail $ "No attribute " ++ name
evalExpr (Constant c) = return c
What motivated the whole thing was the shenanigans required for implementing break. The break definition is reasonable, but what it does to the while definition is a bit much:
eval (Break) = do
env <- get
when (loopLevel env <= 0) (fail "Can only break in a loop!")
put env { flow = Breaking }
eval (While condition block) = do
setup
loop
cleanup
where
setup = do
env <- get
let level = loopLevel env
put env { loopLevel = level + 1 }
loop = do
env <- get
result <- evalExpr condition
when (isTruthy result && flow env == Next) $ do
evalBlock block
-- Pretty ugly! Eat continue.
updatedEnv <- get
when (flow updatedEnv == Continuing) $ put updatedEnv { flow = Next }
loop
cleanup = do
env <- get
let level = loopLevel env
put env { loopLevel = level - 1 }
case flow env of
Breaking -> put env { flow = Next }
Continuing -> put env { flow = Next }
_ -> return ()
I am sure there are more simplifications that can be done here, but the core problem is one of stuffing state somewhere and manually winding out. I'm hoping that CPS will let me stuff book-keeping (like loop exit points) into state and just use those when I need them.
I dislike the split between statements and expressions and worry it might make the CPS transform more work.
This finally gave me a good excuse to try using ContT!
Here's one possible way of doing this: store (in a Reader wrapped in ContT) the continuation of exiting the current (innermost) loop:
newtype M r a = M{ unM :: ContT r (ReaderT (M r ()) (StateT (Map Id Value) IO)) a }
deriving ( Functor, Applicative, Monad
, MonadReader (M r ()), MonadCont, MonadState (Map Id Value)
, MonadIO
)
runM :: M a a -> IO a
runM m = evalStateT (runReaderT (runContT (unM m) return) (error "not in a loop")) M.empty
withBreakHere :: M r () -> M r ()
withBreakHere act = callCC $ \break -> local (const $ break ()) act
break :: M r ()
break = join ask
(I've also added IO for easy printing in my toy interpreter, and State (Map Id Value) for variables).
Using this setup, you can write Break and While as:
eval Break = break
eval (While condition block) = withBreakHere $ fix $ \loop -> do
result <- evalExpr condition
unless (isTruthy result)
break
evalBlock block
loop
Here's the full code for reference:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Interp where
import Prelude hiding (break)
import Control.Applicative
import Control.Monad.Cont
import Control.Monad.State
import Control.Monad.Reader
import Data.Function
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
type Id = String
data Statement
= Print Expression
| Assign Id Expression
| Break
| While Expression [Statement]
| If Expression [Statement]
deriving Show
data Expression
= Var Id
| Constant Value
| Add Expression Expression
| Not Expression
deriving Show
data Value
= String String
| Int Integer
| None
deriving Show
data Env = Env{ loopLevel :: Int
, flow :: Flow
}
data Flow
= Breaking
| Continuing
| Next
deriving Eq
newtype M r a = M{ unM :: ContT r (ReaderT (M r ()) (StateT (Map Id Value) IO)) a }
deriving ( Functor, Applicative, Monad
, MonadReader (M r ()), MonadCont, MonadState (Map Id Value)
, MonadIO
)
runM :: M a a -> IO a
runM m = evalStateT (runReaderT (runContT (unM m) return) (error "not in a loop")) M.empty
withBreakHere :: M r () -> M r ()
withBreakHere act = callCC $ \break -> local (const $ break ()) act
break :: M r ()
break = join ask
evalExpr :: Expression -> M r Value
evalExpr (Constant val) = return val
evalExpr (Var v) = gets $ fromMaybe err . M.lookup v
where
err = error $ unwords ["Variable not in scope:", show v]
evalExpr (Add e1 e2) = do
Int val1 <- evalExpr e1
Int val2 <- evalExpr e2
return $ Int $ val1 + val2
evalExpr (Not e) = do
val <- evalExpr e
return $ if isTruthy val then None else Int 1
isTruthy (String s) = not $ null s
isTruthy (Int n) = n /= 0
isTruthy None = False
evalBlock = mapM_ eval
eval :: Statement -> M r ()
eval (Assign v e) = do
val <- evalExpr e
modify $ M.insert v val
eval (Print e) = do
val <- evalExpr e
liftIO $ print val
eval (If cond block) = do
val <- evalExpr cond
when (isTruthy val) $
evalBlock block
eval Break = break
eval (While condition block) = withBreakHere $ fix $ \loop -> do
result <- evalExpr condition
unless (isTruthy result)
break
evalBlock block
loop
and here's a neat test example:
prog = [ Assign "i" $ Constant $ Int 10
, While (Var "i") [ Print (Var "i")
, Assign "i" (Add (Var "i") (Constant $ Int (-1)))
, Assign "j" $ Constant $ Int 10
, While (Var "j") [ Print (Var "j")
, Assign "j" (Add (Var "j") (Constant $ Int (-1)))
, If (Not (Add (Var "j") (Constant $ Int (-4)))) [ Break ]
]
]
, Print $ Constant $ String "Done"
]
which is
i = 10
while i:
print i
i = i - 1
j = 10
while j:
print j
j = j - 1
if j == 4:
break
so it will print
10 10 9 8 7 6 5
9 10 9 8 7 6 5
8 10 9 8 7 6 5
...
1 10 9 8 7 6 5