Would it be possible to give checkM the following type instead:
checkM :: RenderMessage master msg =>
(a -> GHandler sub master (Either msg b)) ->
Field sub master a -> Field sub master b
The reason is the following:
I have a form that asks for a user name. Using checkM, I immediately look up in the database whether the entered user exists:
userField = checkM userexists textField
userexists input = do
mbuser <- runDB $ getBy $ UniqueName input
return $ case mbuser of
Nothing -> Left ("This user does not exist!" :: Text)
(Just (Entity uid _)) -> Right input
-- I would like to write "return Right uid" above!
However, I can only return input::Text, so right after the form has accepted the user input, I need to do another database lookup for the same name to get the database key for that user, which is what I really wanted.
(This example is largely simplified. Essentially, I want to get the database keys for a series of different user inputs (all in one form), which I can only ask as TextFields, or not?)
The reason the type signature looks that way is that there are two aspects to a Field: how you parse it, and how you render it. checkM only changes how you parse the field, but the rendering function (fieldView) remains unmodified. Therefore, the value needs to keep the same type.
The simplest way I can think of to get the behavior you want is to have a function which can get a value of the old type from a value of the new type. That way, given a new value, we can just apply that function to it and get the old value for rendering purposes. Here's what the code would look like:
checkM' :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg b))
-> (b -> a)
-> Field sub master a
-> Field sub master b
checkM' f inv field = field
{ fieldParse = \ts -> do
e1 <- fieldParse field ts
case e1 of
Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
, fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
}
So in your case, you could use it by changing the last line in userexists to:
(Just (Entity uid _)) -> Right (input, uid)
and then defining userField as
userField = checkM' userexists fst textField
I think a function like checkM makes sense to include in yesod-form, but hopefully with a better name ;).
Related
When using reflex-gi-gtk-0.2.0.0
I can access a dynamic from within an event:
submitButtonE4 <- eventOnSignal submitButton #clicked
(
do
let processDyn dynCompany = do
case dynCompany of
Just company -> do
path <- chartAnnualROA company fileOptions800x600 --generateChart company
Gtk.imageClear chartImage
Gtk.set chartImage [#file := T.pack defaultReportPath]
--return x -- path
case T.null $ T.pack path of
True -> return "" --dynCompany
Nothing -> return "" -- dynCompany
return $ ffor maybeCompanyDyn processDyn
>>= )
But in order to be evaluated, I need to bind it to a label:
sink submitClickStatusLabel [#label :== ffor submitButtonE4 (T.pack . show)]
which does not work as it is in Dynamic (SpiderTimeline x) (IO (Maybe Company)).
So instead I must go and get the info that the dynamic was bound to:
(
do
name <- Gtk.get companyCboxBoxEntryWidget #text
case Map.lookup name companyMap of
Just company -> do
path <- chartAnnualROA company fileOptions800x600 --generateChart company
Gtk.imageClear chartImage
Gtk.set chartImage [#file := T.pack defaultReportPath]
return path
Nothing -> return "../investingRIO/src/Data/Reports/initialChart.svg"
>>= )
and now I can sink it and cause evalution.
sink submitClickStatusLabel [#label :== ffor submitButtonE (T.pack . show)]
I am unable to find any way to force the evaluation when using the first method. How do I force the evalution without sinking to another widget?
Thanks
Here is the new version, based on Kritzefitz's answer.
An event for selecting a company from a combobox, which is same as before
companySelectionE <- eventOnAttribute companyCboxBoxEntryWidget #text
Replaced dynamic with a behavior.
companySelectionB <- hold Nothing $ ffor companySelectionE (`Map.lookup` companyMap)
generateChart (renamed from processDyn) returns a () instead of a FilePath, which was an attempt at forcing evaluation, now done by performEvent.
let
generateChart company = do
case company of
Just companyJ -> do
chartAnnualROA companyJ fileOptions800x600
Gtk.imageClear chartImage
Gtk.set chartImage [#file := T.pack defaultReportPath]
return ()
Nothing -> return ()
submitClickedE now uses eventOnSignal0 instead of eventOnSignal
submitClickedE <- eventOnSignal0 submitButton #clicked
Creating a chart from the selected company is now a behavior instead of a dynamic.
let generateChartB = generateChart <$> companySelectionB
Now I use <# to create a new event from the submit event and generate chart behavior.
let generateChartE = generateChartB <# submitClickedE
And the use of performEvent, which eliminated all the labels I was creating and sinking to in an attempt to get my IO to evaluate. It also eliminated the FilePath return from generateChart, aslo an attempt to force evaluation.
processedCompany <- performEvent $ runGtk <$> generateChartE
Thank cleared up a lot of things for me, thanks.
Here it is in a single quote for easier reading:
companySelectionE <- eventOnAttribute companyCbox #text
companySelectionB <- hold Nothing $ ffor companySelectionE (`Map.lookup` companyMap)
let
generateChart company = do
case company of
Just companyJ -> do
chartAnnualROA companyJ fileOptions800x600
Gtk.set chartImage [#file := T.pack defaultReportPath]
return ()
Nothing -> return ()
submitClickedE <- eventOnSignal0 submitButton #clicked
let generateChartB = generateChart <$> companySelectionB
let generateChartE = generateChartB <# submitClickedE
processedCompany <- performEvent $ runGtk <$> generateChartE
I think most of your trouble comes from the fact, that you want to do substantial amounts of work inside eventOnSignal . This place is not intended to do the actual heavy lifting of your business logic and it doesn't provide you with the proper context to effectively work with reactive values, such as Dynamics, as you are currently experiencing.
The actual use case for the eventOnSignal* family of functions is to obtain basic inputs for your reactive network. The input provided by a button doesn't carry any actual information. It just provides the information when the button has been clicked. For cases like this you usually don't want to use eventOnSignal directly, but rather eventOnSignal0, so let's do that:
submitClickedE <- eventOnSignal0 submitButton #clicked
The type returned by this is submitClickedE :: Event t (). As you can see, the Event has a () as its value, which is what we want, because merely clicking the button doesn't produce any value by itself. But you want to call an IO-producing function on the value inside processDyn, so let's first construct the IO action you want to execute:
let processDynD = processDyn <$> dynCompany
The assignment here has the type processDynD :: Dynamic t (IO (Maybe Company)). As you can see, the IO hasn't been executed yet. Luckily reflex provides an operation to execute IO actions inside reactive values, called performEvent :: Event t (Performable m a) -> m (Event t a). There are two things about this type, that don't quite fit what we need at the moment. First, it expects the monad to be performed to be a Performable m whereas we have IO, but we will get to that in a moment. The second and more pressing concern is that performEvent expects an Event, not a Dynamic. This makes sense, because you can't execute an IO action continuously. You have to decide when the IO action is executed.
AIUI you want the IO to be executed, when the submitButton is clicked. So we want an Event that fires whenever submitClickedE fires, but it should fire the current value inside processDynD. Doing something like this is called “sampling a Behavior with an Event” and can be done using the operator (<#). In your case you want to sample a Dynamic, but you can always turn a Dynamic into a Behavior using current. So to get the expected Event you can use this:
let processDynE = current processDynD <# submitClickedE
The assignment has the value processDynE :: Event t (IO (Maybe Company)). But as you can see, the IO still hasn't been executed. We can now do that using performEvent as discussed earlier:
processedCompany <- performEvent $ runGtk <$> processDynE
We use runGtk to lift the IO in processDynE to the required Performable m. The returned value has the type processedCompany :: Event t (Maybe Company). You can now sink this into your output label, as was your original intention:
sink submitClickStatusLabel [#label :== T.pack . show <$> processedCompany]
Note though, that unlike your original attempt, we now ended up with an Event instead of a Dynamic. If you actually need a Dynamic from all of this, you have to construct it from the Event using holdDyn initialValue processedCompany. But then you have to provide an initialValue because otherwise there is no value for the Dynamic before the submitButton has been clicked for the first time.
I'm a Haskell beginner, so apologies in advance!
I've been following the Persistent tutorial here.
I have a data model with a uniqueness constraint:
Book
gutId Int
UniqueGutId gutId
...
author [AuthorId]
...
Author
gutId Int
UniqueAuthorGutId gutId
...
And when I go to insert a record using this:
runSqlite "test.db" $ do
runMigration migrateAll
-- FIXME: This won't work if there's an author that's already in the database.
authorIds <- mapM insert authors
It won't work if the record is already in the database. (It'll just return an exception.) I can do this instead:
authorIds <- mapM insertUnique authors
But the problem is, I need to use authorIds to update Book records later. So I'm just wondering if anyone knows of an easy way to insert a record if it doesn't exist, and return the new key, or get the record key if it already exists, so that I have an array of keys either way. The full code at this point is up here.
You just need to perform both actions you mentioned yourself:
authorIds <- forM authors $ \a -> do
res <- insertUnique a
case res of
Just key -> return key
_ -> fromJust <$> getBy (authorGutId a)
How about
authorIds <- mapM (fmap (either entityKey id) . insertBy) authors
insertBy :: _ => -- some constraints
record -> -- given some record, try to insert it
_ ( -- in some monad
Either (Entity record) (Key record)
-- if found: Left existing
-- otherwise: Right newKey
)
Data.Either.either :: (l -> o) -> (r -> o) -> Either l r -> o
-- eliminator for Either
-- purpose and implementation completely determined by type
We use insertBy to try to insert the record. fmap drills underneath the monad, and either entityKey id extracts the Key.
I’m writing a program that validates a complex data structure according to a number of complex rules. It inputs the data and outputs a list of messages indicating problems with the data.
Think along these lines:
import Control.Monad (when)
import Control.Monad.Writer (Writer, tell)
data Name = FullName String String | NickName String
data Person = Person { name :: Name, age :: Maybe Int }
data Severity = E | W | C -- error/warning/comment
data Message = Message { severity :: Severity, code :: Int, title :: String }
type Validator = Writer [Message]
report :: Severity -> Int -> String -> Validator ()
report s c d = tell [Message s c d]
checkPerson :: Person -> Validator ()
checkPerson person = do
case age person of
Nothing -> return ()
Just years -> do
when (years < 0) $ report E 1001 "negative age"
when (years > 200) $ report W 1002 "age too large"
case name person of
FullName firstName lastName -> do
when (null firstName) $ report E 1003 "empty first name"
NickName nick -> do
when (null nick) $ report E 1004 "empty nickname"
For documentation, I also want to compile a list of all messages this program can output. That is, I want to obtain the value:
[ Message E 1001 "negative age"
, Message W 1002 "age too large"
, Message E 1003 "empty first name"
, Message E 1004 "empty nickname"
]
I could move the messages out of checkPerson into some external data structure, but I like it when the messages are defined right at the spot where they are used.
I could (and probably should) extract the messages from the AST at compile time.
But the touted flexibility of Haskell made me thinking: can I achieve that at runtime? That is, can I write a function
allMessages :: (Person -> Validator ()) -> [Message]
such that allMessages checkPerson would give me the above list?
Of course, checkPerson and Validator need not stay the same.
I can almost (not quite) see how I could make a custom Validator monad with a “backdoor” that would run checkPerson in a sort of “reflection mode,” traversing all paths and returning all Messages encountered. I would have to write a custom when function that would know to ignore its first argument under some circumstances (which ones?). So, a kind of a DSL. Perhaps I could even emulate pattern matching?
So: can I do something like this, how, and what would I have to sacrifice?
Please feel free to suggest any solutions even if they do not exactly fit the above description.
This kind of half-static analysis is basically exactly what arrows were invented for. So let's make an arrow! Our arrow will basically be just a Writer action, but one that remembers what messages it might have spit out at any given moment. First, some boilerplate:
{-# LANGUAGE Arrows #-}
import Control.Arrow
import Control.Category
import Control.Monad.Writer
import Prelude hiding (id, (.))
Now, the type described above:
data Validator m a b = Validator
{ possibleMessages :: [m]
, action :: Kleisli (Writer m) a b
}
runValidator :: Validator m a b -> a -> Writer m b
runValidator = runKleisli . action
There are some straightforward instances to put in place. Of particular interest: the composition of two validators remembers messages from both the first action and the second action.
instance Monoid m => Category (Validator m) where
id = Validator [] id
Validator ms act . Validator ms' act' = Validator (ms ++ ms') (act . act')
instance Monoid m => Arrow (Validator m) where
arr f = Validator [] (arr f)
first (Validator ms act) = Validator ms (first act)
instance Monoid m => ArrowChoice (Validator m) where
left (Validator ms act) = Validator ms (left act)
All the magic is in the operation that actually lets you report something:
reportWhen :: Monoid m => m -> (a -> Bool) -> Validator m a ()
reportWhen m f = Validator [m] (Kleisli $ \a -> when (f a) (tell m))
This is the operation that notices when you're about to output a possible message, and makes a note of it. Let's copy your types and show how to code up checkPerson as an arrow. I've simplified your messages a little bit, but nothing important is different there -- just less syntactic overhead in the example.
type Message = String
data Name = FullName String String | NickName String -- http://www.kalzumeus.com/2010/06/17/falsehoods-programmers-believe-about-names/
data Person = Person { name :: Name, age :: Maybe Int }
checkPerson :: Validator Message Person ()
checkPerson = proc person -> do
case age person of
Nothing -> returnA -< ()
Just years -> do
"negative age" `reportWhen` (< 0) -< years
"age too large" `reportWhen` (>200) -< years
case name person of
FullName firstName lastName -> do
"empty first name" `reportWhen` null -< firstName
NickName nick -> do
"empty nickname" `reportWhen` null -< nick
I hope you'll agree that this syntax is not too far removed from what you originally wrote. Let's see it in action in ghci:
> runWriter (runValidator checkPerson (Person (NickName "") Nothing))
((),"empty nickname")
> possibleMessages checkPerson
["empty nickname","empty first name","age too large","negative age"]
I have a function, target say, which demands a parameter of type
target :: Action m UserId -> something
where m is any monad.
I acquire the parameter from an existing function, call it "func"
func :: something -> Action m UserId
to which I wish to retrofit an ErrorT transformer
func :: something -> ErrorT String (Action m) UserId
When I use runErrorT on func in order to extract the successful/failed result, I of course get a result of type
Action m (Either String UserId)
I.e. the either representing success or failure is embedded in the surrounding monad. This is great for some purposes e.g. testing for left and right in the context of the Action monad.
What I really need is a version of runErrorT which returns
Either String (Action m UserId)
because then I could just take the Right value and use it. What do I do in these circumstances? Alternatively is there a clever way of rejigging
Action m (Either String UserId) -> Either String (Action m UserId)
but where I don't have access to the necessary constructor
UserId -> Action m UserId
since it so happens that Action is itself a transformer
type Action = ReaderT MongoDBContext
Let's say you have
func :: a -> ErrorT String (Action m) UserId
target :: Action m UserId -> b
Then
run :: a -> Action m (Either String b)
run a = do
result <- runErrorT $ func a
return $ case result of
Left str -> Left str
Right uid -> Right $ target (return uid)
Or more succinctly
run = runErrorT . fmap (target . return) . func
In general, this can't be done without knowledge of the specific m. For example, this is no function of type IO (Either String Int) -> Either String (IO Int) that doesn't use unsafePerformIO or something like that.
You can write something like:
dupNoEx :: IO (Either String Int) -> IO (Either String (IO Int))
dupNoEx act = do
ev <- act
case v of
Left s -> return $ Left s
Right i -> return . Right $ return i
but, I don't know how valuable it might be.
I'm using the yesod scaffold. I'm struggeling a bit with how to get a value from the settings.yml file,
The relevant part of the settings.yml file looks like this,
Default: &defaults
host: "*4" # any IPv4 host
port: 3000
approot: "http://localhost:3000"
admins: ["someEmail#gmail.com", "someOtherEmail#gmail.com"]
And then in my Foundation.hs file I have a method to check if the users email (using googleauth) matches a pre-specified email,
admins = ["someEmail#gmail.com", "someOtherEmail#gmail.com"]
isAdmin (Just (Entity _ user)) | elem (userIdent user) admins = Authorized
| otherwise = AuthenticationRequired
isAdmin Nothing = AuthenticationRequired
My goal is to replace the admins function with the one from the the settings.yml file because it seems more appropriate.
Any help on doing this would be greatly appreciated!
EDIT:
Okay, I've come as far as fetching the newly made "extra" with the following method,
admins = do
madmins <- extraAdmins getExtra
case madmins of
Nothing -> return Nothing
Just admins -> return admins
But the GHC throws this at me,
Foundation.hs:161:28:
Couldn't match expected type `Extra'
with actual type `Handler Extra'
In the first argument of `extraAdmins', namely `getExtra'
In a stmt of a 'do' block: madmins <- extraAdmins getExtra
In the expression:
do { madmins <- extraAdmins getExtra;
case madmins of {
Nothing -> return Nothing
Just admins -> return admins } }
Is there a way to convert it from Handler Extra to Extra, or am I simply doing it the wrong way?
At the end of the Settings.hs file in the scaffolding, there's the definition of Extra and how to parse it:
data Extra = Extra
{ extraCopyright :: Text
, extraAnalytics :: Maybe Text -- ^ Google Analytics
} deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
<*> o .:? "analytics"
You can add the extra data you want to this structure and parse it there. From the rest of your app, you can access this value with getExtra (defined in Foundation.hs).
You're a bit confused about the types of getExtra and extraAdmins.
I'm guessing they're like this:
getExtra :: Handler Extra
extraAdmins :: Extra -> [Text] -- maybe?
If so, something like this should work:
isAdmin :: User -> Handler Bool
isAdmin u = do
extra <- getExtra
return $ userIdent u `elem` extraAdmins extra