View source on Github

Joins

You might be thinking this is something that Persistent could automate away for us. Well, in theory yes, but there are two complications to be taken into account: there might be multiple relations between entities (e.g., a car could have both an owner and a mechanic), or that might not be any relations. In my opinion, the simplest, most consistent API results from just making these things explicit parameters.

type PersonPair = ( PersonId , Person ) type CarPair = ( CarId , Car ) type Result = [( PersonPair , [ CarPair ])]

{-# LANGUAGE TypeFamilies, TemplateHaskell, MultiParamTypeClasses, GADTs, QuasiQuotes, OverloadedStrings, FlexibleContexts #-} import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH import Database.Persist.Query.Join ( SelectOneMany (..), selectOneMany) import Control.Monad.IO.Class (liftIO) -- We'll use the SQL-enhanced joins. If you want the in-application join -- behavior instead, just import runJoin from Database.Persist.Query.Join import Database.Persist.Query.Join.Sql (runJoin) share [mkPersist sqlSettings, mkMigrate "migrateAll" ] [persist| Person name String Car owner PersonId name String |] main :: IO () main = withSqliteConn ":memory:" $ runSqlConn $ do runMigration migrateAll bruce <- insert $ Person "Bruce Wayne" insert $ Car bruce "Bat Mobile" insert $ Car bruce "Porsche" -- this could go on a while peter <- insert $ Person "Peter Parker" -- poor Spidey, no car logan <- insert $ Person "James Logan" -- Wolverine insert $ Car logan "Harley" britt <- insert $ Person "Britt Reid" -- The Green Hornet insert $ Car britt "The Black Beauty" results <- runJoin (selectOneMany ( CarOwner <-.) carOwner) { somOrderOne = [ Asc PersonName ] } liftIO $ printResults results printResults :: [( Entity Person , [ Entity Car ])] -> IO () printResults = mapM_ goPerson where goPerson :: ( Entity Person , [ Entity Car ]) -> IO () goPerson (( Entity _personid person), cars) = do putStrLn $ personName person mapM_ goCar cars putStrLn "" goCar :: ( Entity Car ) -> IO () goCar ( Entity _carid car) = putStrLn $ " " ++ carName car

Monadic Forms

A non-standard form layout

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-} import Yesod import Control.Applicative import Data.Text ( Text ) data Monadic = Monadic mkYesod "Monadic" [parseRoutes| / RootR GET |] instance Yesod Monadic instance RenderMessage Monadic FormMessage where renderMessage _ _ = defaultFormMessage data Person = Person { personName :: Text , personAge :: Int } deriving Show personForm :: Html -> MForm Monadic Monadic ( FormResult Person , Widget ) personForm extra = do (nameRes, nameView) <- mreq textField "this is not used" Nothing (ageRes, ageView) <- mreq intField "neither is this" Nothing let personRes = Person <$> nameRes <*> ageRes let widget = do toWidget [lucius| ##{fvId ageView} { width: 3 em; } |] [whamlet| # {extra} <p> Hello , my name is # ^{fvInput nameView} \ and I am # ^{fvInput ageView} \ years old. # <input type =submit value= "Introduce myself" > |] return (personRes, widget) getRootR :: Handler RepHtml getRootR = do ((res, widget), enctype) <- runFormGet personForm defaultLayout [whamlet| <p> Result : #{show res} <form enctype=#{enctype}> ^{widget} |] main :: IO () main = warpDebug 3000 Monadic

fromString "this is not used" == FieldSettings { fsLabel = "this is not used" , fsTooltip = Nothing , fsId = Nothing , fsName = Nothing , fsClass = [] }

fsLabel

fsTooltip

Well, that's not exactly true. It would compile and build, but you wouldn't have a submit button.

Input forms

You use runInputPost and runInputGet .

and . You use ireq and iopt . These functions now only take two arguments: the field type and the name (i.e., HTML name attribute) of the field in question.

and . These functions now only take two arguments: the field type and the name (i.e., HTML attribute) of the field in question. After running a form, it returns the value. It doesn't return a widget or an encoding type.

If there are any validation errors, the page returns an "invalid arguments" error page.

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-} import Yesod import Control.Applicative import Data.Text ( Text ) data Input = Input mkYesod "Input" [parseRoutes| / RootR GET /input InputR GET |] instance Yesod Input instance RenderMessage Input FormMessage where renderMessage _ _ = defaultFormMessage data Person = Person { personName :: Text , personAge :: Int } deriving Show getRootR :: Handler RepHtml getRootR = defaultLayout [whamlet| <form action=@{ InputR }> <p> My name is # <input type =text name=name> \ and I am # <input type =text name=age> \ years old. # <input type =submit value= "Introduce myself" > |] getInputR :: Handler RepHtml getInputR = do person <- runInputGet $ Person <$> ireq textField "name" <*> ireq intField "age" defaultLayout [whamlet|<p>#{show person}|] main :: IO () main = warpDebug 3000 Input

Custom fields

An error message saying validation failed.

The parsed value.

Nothing, indicating that no data was supplied.