The code below is from the Home.hs file created by the yesod-simple scaffold.
I like to do simple string manipulation on text input but don't know how to parse it into a Text value.
How, for example, can I use toUpper on fileDescription?
I've tried using lookupPostParam
but I'm struggling with it's type signature:
lookupPostParam :: MonadHandler m => Text -> m (Maybe Text)
Home.hs
module Handler.Home where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-
commentList")
This is unfortunately a fault in documentation and communication.
Given
lookupPostParam :: (MonadResource m, MonadHandler m) => Text -> m (Maybe Text)
the reader is meant to infer that m is not only a MonadResouce and a MonadHandler but also Monad. This tiny little line of code packs up a lot of intent into a very small sentence; it's a wart that so much of Haskell library usage is left implicit and subtextual. For example, to call toUpper on the Text inside this type you are meant to do this:
{-# language OverloadedStrings #-}
foo :: (MonadResource m, MonadHandler m) => m (Maybe Text)
foo = do
valueMaybe <- lookupPostParam "key"
case valueMaybe of
Just value ->
pure (toUpper value)
Nothing ->
Nothing
Note that the monad stack (MonadHandler, MonadResource) has "infected" your code. This is meant to be intentional, so as to constrain you via the type checker to only run this function in the intended Yesod environment/state machine/context/whatever.
However
You are using yesod-forms and it would be nice to do the same thing within that framework. As with lookupPostParam, we can take advantage of the monad-applicative-functor typeclasses.
We can adapt this to the Form FileForm value that you have.
sampleForm :: AForm Handler FileForm
sampleForm =
FileForm <$> fileAFormReq "Choose a file"
<*> (toUpper <$> areq textField textSettings Nothing)
I think the types of yesod-forms changed between releases. I'm copying my types off the latest version as of writing, 1.4.11.
Here we take advantage of the Monad m => Functor (AForm m) instance. Knowing that we are indeed in a monad (the Handler monad) means we can use fmap and its infixed sibling <$> on the value returned by areq textField textSettings Nothing. This allows us to lift arbitrary functions acting on Text into the AForm m stack. For example, here we went from Text -> Text to AForm Handler Text -> AForm Handler Text.
Hope that helps.
Related
I have a question regarding use of Exceptions with a transformer stack.
I am a trying to develop some networking software, specifically implement
the GTP control protocol on S5 interface.
I am finding it difficult to get Exceptions work the transformer stack.
import Control.Monad (unless)
import Control.Exception
....
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Except
...
data GtpcModSt = GtpcModSt { sock :: Socket
, rcvdBytes :: BS.ByteString
, s5cTeidKey :: Word32
---- ....
} --deriving (Show)
type EvalGtpC a = (StateT GtpcModSt (ExceptT GtpcExceptions IO )) a
-- deriving (Functor, Applicative, Monad)
gtpcProcess = loop
where loop = do
rcvAndProcessGtpc `catch` (\e -> do
print "Exception handler"
print (e :: SomeException))
loop
rcvAndProcessGtpc :: EvalGtpC ()
rcvAndProcessGtpc = do
sock <- gets sock
(msg, addr) <- liftIO $ recvFrom sock 1000
modify (\x -> x {rcvdBytes = msg, sndrAddr = addr})
processMsg
processMsg :: EvalGtpC ()
processMsg = do
-- validateSrc
-----
--....
msg <- gets gtpMsg
processGtpc $ msgType msg
-- createSessionRequest
processGtpc :: Word8 -> EvalGtpC ()
processGtpc 32 = do
myState#GtpcModSt {..} <- get
.....
sessParams <- return $ foldl ieInfo (SessionParams { imsi = Nothing
, mei = Nothing
, msisdn = Nothing
, senderFteidKey = Nothing
, senderIpV4Addr = Nothing
, senderIpV6Addr = Nothing
, pgwFteidKey = Nothing
, pgwIpV4Addr = Nothing
, pgwIpV6Addr = Nothing
, apn = Nothing
, paaPdnType = Nothing
, pco = Nothing
, bearerContext = []
, unDecodedIe = []
, unSupportedIe = []
}) $ msgIeList gtpMsg
ueApn <-return $ fromMaybe (throwE BadIe) (apn sessParams)
apnCfg <- return $ fromMaybe (throw BadIe) $ Map.lookup ueApn apnProfile
thisSndrFteidKey <-return $ fromMaybe (throw BadIe) (senderFteidKey sessParams)
I think that I should use throwE/catchE from Control.Monad.Trans.Except. However, throwE does not even compile when used with my transformer monad, as shown here:
apnCfg <- return $ fromMaybe (throw UnknownApn) $ Map.lookup ueApn apnProfile
Using throw from Control.Exception gets past the compilation stage but I am not sure it will work.
Should I not be using Exception in a transformer monad that has IO as its base?
I think that I should use throwE/catchE from Control.Monad.Trans.Except. However, throwE does not even compile when used with my transformer monad, as shown here:
apnCfg <- return $ fromMaybe (throw UnknownApn) $ Map.lookup ueApn apnProfile
Using throw from Control.Exception gets past the compilation stage but I am not sure it will work.
This can be solved by following the types. In your do-block, we have:
-- I won't use the synonym here, for the sake of explicitness:
return :: a -> StateT GtpcModSt (ExceptT GtpcExceptions IO) a
The type of throwE is:
throwE :: Monad m => e -> ExceptT e m a
That being so, what you want is:
apnCfg <- maybe (lift $ throwE UnknownApn) return $ Map.lookup ueApn apnProfile
Firstly, you only need return if you aren't throwing (maybe is more convenient than fromMaybe for expressing that). Secondly, throwE produces an ExceptT computation that you need to lift to the outer, StateT layer. You can make the lift implicit by using mtl instead of transformers directly. To do that, change your imports from...
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Except
... to:
import Control.Monad.State.Strict
import Control.Monad.Except
Then you can simply write (using the throwError method from MonadError):
apnCfg <- maybe (throwError UnknownApn) return $ Map.lookup ueApn apnProfile
EDITED 2015-11-29: see bottom
I'm trying to write an application that has a do-last-action-again button. The command in question can ask for input, and my thought for how to accomplish this was to just rerun the resulting monad with memoized IO.
There are lots of posts on SO with similar questions, but none of the solutions seem to work here.
I lifted the memoIO code from this SO answer, and changed the implementation to run over MonadIO.
-- Memoize an IO function
memoIO :: MonadIO m => m a -> m (m a)
memoIO action = do
ref <- liftIO $ newMVar Nothing
return $ do
x <- maybe action return =<< liftIO (takeMVar ref)
liftIO . putMVar ref $ Just x
return x
I've got a small repro of my app's approach, the only real difference being my app has a big transformer stack instead of just running in IO:
-- Global variable to contain the action we want to repeat
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
-- Run an action and store it as the action to repeat
repeatable :: IO String -> IO String
repeatable action = do
writeIORef actionToRepeat action
action
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
The idea being I can store an action with memoized IO in an IORef (via repeatable) when I record what was last done, and then do it again it out with doRepeat.
I test this via:
-- IO function to memoize
getName :: IO String
getName = do
putStr "name> "
getLine
main :: IO ()
main = do
repeatable $ do
memoized <- memoIO getName
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
with expected output:
name> isovector
hello isovector
hello isovector
but actual output:
name> isovector
hello isovector
name> wasnt memoized
hello wasnt memoized
I'm not entirely sure what the issue is, or even how to go about debugging this. Gun to my head, I'd assume lazy evaluation is biting me somewhere, but I can't figure out where.
Thanks in advance!
EDIT 2015-11-29: My intended use case for this is to implement the repeat last change operator in a vim-clone. Each action can perform an arbitrary number of arbitrary IO calls, and I would like it to be able to specify which ones should be memoized (reading a file, probably not. asking the user for input, yes).
the problem is in main you are creating a new memo each time you call the action
you need to move memoized <- memoIO getName up above the action
main :: IO ()
main = do
memoized <- memoIO getName --moved above repeatable $ do
repeatable $ do
--it was here
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
edit: is this acceptable
import Data.IORef
import System.IO.Unsafe
{-# NOINLINE actionToRepeat #-}
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
type Repeatable a = IO (IO a)
-- Run an action and store the Repeatable part of the action
repeatable :: Repeatable String -> IO String
repeatable action = do
repeatAction <- action
writeIORef actionToRepeat repeatAction
repeatAction
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
-- everything before (return $ do) is run just once
hello :: Repeatable String
hello = do
putStr "name> "
name <- getLine
return $ do
putStr "hello "
putStrLn name
return name
main :: IO ()
main = do
repeatable hello
doRepeat
return ()
I came up with a solution. It requires wrapping the original monad in a new transformer which records the results of IO and injects them the next time the underlying monad is run.
Posting it here so my answer is complete.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
import Control.Applicative (Applicative(..))
import Data.Dynamic
import Data.Maybe (fromJust)
import Control.Monad.RWS
-- | A monad transformer adding the ability to record the results
-- of IO actions and later replay them.
newtype ReplayT m a =
ReplayT { runReplayT :: RWST () [Dynamic] [Dynamic] m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadState [Dynamic]
, MonadWriter [Dynamic]
, MonadTrans
)
-- | Removes the first element from a list State and returns it.
dequeue :: MonadState [r] m
=> m (Maybe r)
dequeue = do
get >>= \case
[] -> return Nothing
(x:xs) -> do
put xs
return $ Just x
-- | Marks an IO action to be memoized after its first invocation.
sample :: ( MonadIO m
, Typeable r)
=> IO r
-> ReplayT m r
sample action = do
a <- dequeue >>= \case
Just x -> return . fromJust $ fromDynamic x
Nothing -> liftIO action
tell [toDyn a]
return a
-- | Runs an action and records all of its sampled IO. Returns a
-- action which when invoked will use the recorded IO.
record :: Monad m
=> ReplayT m a
-> m (m a)
record action = do
(a, w) <- evalRWST (runReplayT action) () []
return $ do
evalRWST (runReplayT action) () w
return a
I have a doubt of why is this happening. I have been following the "Yesod Web" ebook but with a scaffolded site. When I arrived to a position that I wanted to apply the function of "plural" inside a "messages" file, the compiler returns this error:
Foundation.hs:52:1: Not in scope: `plural'
Where plural is declared in the same hs file as the one that I am calling the "hamlet" one. However, if I move the function declaration before the line #52 in the "Foundation.hs" file, then the error vanishes and it let me compile it effectively. Why does this happen??
module Handler.UserProfile where
import Import
import Data.Maybe (fromMaybe)
import Data.Text (pack, unpack)
viewCountName :: Text
viewCountName = "UserProfileViews"
readInt :: String -> Int
readInt = read
plural :: Int -> String -> String -> String
plural 1 x _ = x
plural _ _ y = y
getUserProfileR :: Handler RepHtml
getUserProfileR = do
viewCount <- lookupSession viewCountName
>>= return . (1 +) . readInt . unpack . fromMaybe "0"
setSession viewCountName (pack $ show viewCount)
maid <- maybeAuth
--msg <- getMessageRender
let user = case maid of
Nothing -> "(Unknown User ID)" --show MsgHello --
Just (Entity _ u) -> userEmail u
defaultLayout $ do
setTitleI MsgUserProfile
$(widgetFile "nhUserProfile")
Take a look at the GHC users manual: http://www.haskell.org/ghc/docs/7.4.2/html/users_guide/template-haskell.html#id684916
The staging restriction in play is described in the second bullet point:
You can only run a function at compile time if it is imported from
another module. That is, you can't define a function in a module, and
call it from within a splice in the same module. (It would make sense
to do so, but it's hard to implement.)
I tried modifying a Yesod project, and came across a weird error. First I will present the working form code, and the bare-bones broken code with error message.
type PForm x = ProductConfig ->
Html ->
MForm ReScheduler ReScheduler (FormResult x, Widget)
working code next
productForm :: PForm SelectedProduct
productForm config extra = do
let pInfo' = pInfo config
aDays' = aDays config
products = (catMaybes . pNametoText) pInfo'
versions' = map consVersionPair pInfo'
productInfo <- mapM generateSelectFields versions'
(dateRes, dateView) <- mreq (selectField aDays') "placeHolder" Nothing
(mailRes, mailView) <- mreq emailField "E-Mail Address" Nothing
(noteRes, noteView) <- mreq textareaField
"Notes"
Nothing
let productVersion = reduceFormResults $
map flagSelected $
map fst productInfo
versionViews = map snd productInfo
let widget =
toWidget $(widgetFile "firmware") :: Widget
return (makeSelected productVersion dateRes mailRes noteRes, widget)
The above code works fine. Here's the broken code, followed by the error and some observations.
type RForm x = [KeyJobPair] ->
Html ->
MForm ReScheduler ReScheduler (FormResult x, Widget)
statusForm :: RForm ModData
statusForm kjPairs extra = do
-- let bPairs = buttonPairs kjPairs
-- statusPairs = map (pack . show &&& id) $
-- ([minBound .. maxBound] :: [Status])
-- (jobRes,jobView) <- mreq (radioField bPairs) "Scheduled Jobs" Nothing
-- (mailRes, mailView) <- mreq emailField "E-Mail Address" Nothing
-- (noteRes, noteView) <- mreq textareaField "Notes" Nothing
-- (statusRes, statusView) <- mreq (selectField statusPairs) "Status" Nothing
-- let widget = toWidget [hamlet|<p> testing |]
let widget = (toWidget $(widgetFile "status" )) :: Widget
return (ModData <$> undefined <*> undefined <*> undefined, widget)
Handler/Manager.hs:109:19:
No instance for (ToWidget
ReScheduler ReScheduler (GGWidget master0 m0 ()))
arising from a use of `toWidget'
Possible fix:
add an instance declaration for
(ToWidget ReScheduler ReScheduler (GGWidget master0 m0 ()))
In the expression: (toWidget ($(widgetFile "status"))) :: Widget
In an equation for `widget':
widget = (toWidget ($(widgetFile "status"))) :: Widget
In the expression:
do { let widget = ...;
return
(ModData <$> undefined <*> undefined <*> undefined, widget) }
Note the commented out hard-coded hamlet code. This compiles fine. This leads me to believe the problem lies with widgetFile, not toWidget. I noted in the Yesod blog, that sometimes widgetFile wants an explicit :: Widget type signature. I haven't been able to get this to work. Maybe this is just a syntax problem. Feedback would be welcome. In the meantime I can just use hardcoded Hamlet.
This was a syntax issue. It was a matter of proper placement of the type signature.
let widget = toWidget ($(widgetFile "status") :: Widget)
This is correct.
Problem:
I need to compose writer monads of different types in the same Haskell monad transformer stack. Besides using tell to write debug messages I'd also like to use it to write some other data type, e.g. data packets to be transmitted in some other context.
I've checked Hackage for a channelized writer monad. What I was hoping to find was a writer-like monad that supports multiple data types, each representing a distinct "logical" channel in the runWriter result. My searches didn't turn up anything.
Solution Attempt 1:
My first approach at solving the problem was to stack WriterT twice along these lines:
type Packet = B.ByteString
newtype MStack a = MStack { unMStack :: WriterT [Packet] (WriterT [String] Identity) a }
deriving (Monad)
However, I ran into problems when declaring MStack as an instance of both MonadWriter [Packet] and MonadWriter [String]:
instance MonadWriter [String] MStack where
tell = Control.Monad.Writer.tell
listen = Control.Monad.Writer.listen
pass = Control.Monad.Writer.pass
instance MonadWriter [Packet] MStack where
tell = lift . Control.Monad.Writer.tell
listen = lift . Control.Monad.Writer.listen
pass = lift . Control.Monad.Writer.pass
Subsequent complaints from ghci:
/Users/djoyner/working/channelized-writer/Try1.hs:12:10:
Functional dependencies conflict between instance declarations:
instance MonadWriter [String] MStack
-- Defined at /Users/djoyner/working/channelized-writer/Try1.hs:12:10-36
instance MonadWriter [Packet] MStack
-- Defined at /Users/djoyner/working/channelized-writer/Try1.hs:17:10-36
Failed, modules loaded: none.
I understand why this approach is not valid as shown here but I couldn't figure out a way around the fundamental issues so I abandoned it altogether.
Solution Attempt 2:
Since it appears there can only be a single WriterT in the stack, I'm using a wrapper type over Packet and String and hiding the fact in the utility functions (runMStack, tellPacket, and tellDebug below). Here's the complete solution that does work:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Identity
import Control.Monad.Writer
import qualified Data.ByteString as B
type Packet = B.ByteString
data MStackWriterWrapper = MSWPacket Packet
| MSWDebug String
newtype MStack a = MStack { unMStack :: WriterT [MStackWriterWrapper] Identity a }
deriving (Monad, MonadWriter [MStackWriterWrapper])
runMStack :: MStack a -> (a, [Packet], [String])
runMStack act = (a, concatMap unwrapPacket ws, concatMap unwrapDebug ws)
where (a, ws) = runIdentity $ runWriterT $ unMStack act
unwrapPacket w = case w of
MSWPacket p -> [p]
_ -> []
unwrapDebug w = case w of
MSWDebug d -> [d]
_ -> []
tellPacket = tell . map MSWPacket
tellDebug = tell . map MSWDebug
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, ps, ds) = runMStack myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds
Yay, compiles and works!
Solution Non-Attempt 3:
It also occurred to me that this might be a time when I'd roll my own, also including error, reader, and state monad functionality that needs be present in my actual application's transformer stack type. I didn't attempt this.
Question:
Although solution 2 works, is there a better way?
Also, could a channelized writer monad with a variable number of channels be generically implemented as a package? It would seem like that would be a useful thing and I'm wondering why it doesn't already exist.
The output of the Writer monad needs to be a Monoid, but luckily tuples of monoids are monoids too! So this works:
import Control.Monad.Writer
import qualified Data.ByteString as B
import Data.Monoid
type Packet = B.ByteString
tellPacket xs = tell (xs, mempty)
tellDebug xs = tell (mempty, xs)
myFunc :: Writer ([Packet], [String]) ()
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, (ps, ds)) = runWriter myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds
For the record, it is possible to stack two WriterT's on top of each other:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Writer
import Control.Monad.Identity
import qualified Data.ByteString as B
type Packet = B.ByteString
newtype MStack a = MStack { unMStack :: WriterT [Packet] (WriterT [String] Identity) a }
deriving (Functor, Applicative, Monad)
tellDebug = MStack . lift . Control.Monad.Writer.tell
tellPacket = MStack . Control.Monad.Writer.tell
runMStack m =
let ((a, ps), ds) = (runIdentity . runWriterT . runWriterT . unMStack) m
in (a, ps, ds)
myFunc = do
tellDebug ["Entered myFunc"]
tellPacket [B.pack [0..255]]
tellDebug ["Exited myFunc"]
main = do
let (_, ps, ds) = runMStack myFunc
putStrLn $ "Will be sending " ++ (show $ length ps) ++ " packets."
putStrLn "Debug log:"
mapM_ putStrLn ds