Permalink
Browse files

Add simple example

  • Loading branch information...
1 parent 3aa873e commit 5068c0b2a56d31e6558617172b26e1c1a004f4ed @jaspervdj committed Dec 23, 2012
Showing with 92 additions and 0 deletions.
  1. +92 −0 examples/dynamic-list.hs
@@ -0,0 +1,92 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>), (<*>))
+import Data.Text (Text)
+import qualified Snap.Blaze as Snap
+import qualified Snap.Core as Snap
+import qualified Snap.Http.Server as Snap
+import qualified Text.Blaze.Html5 as H
+import Text.Digestive
+import Text.Digestive.Blaze.Html5
+import Text.Digestive.Snap
+
+
+--------------------------------------------------------------------------------
+type Product = Text
+
+
+--------------------------------------------------------------------------------
+type Quantity = Int
+
+
+--------------------------------------------------------------------------------
+data Order = Order
+ { orderProduct :: Product
+ , orderQuantity :: Quantity
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+orderForm :: Monad m => Formlet Text m Order
+orderForm def = Order
+ <$> "product" .: text (orderProduct <$> def)
+ <*> "quantity" .: stringRead "Can't parse quantity" (orderQuantity <$> def)
+
+
+--------------------------------------------------------------------------------
+orderView :: View H.Html -> H.Html
+orderView view = do
+ childErrorList "" view
+
+ label "product" view "Product: "
+ inputText "product" view
+ H.br
+
+ label "quantity" view "Quantity: "
+ inputText "quantity" view
+ H.br
+
+
+--------------------------------------------------------------------------------
+ordersForm :: Monad m => Form Text m [Order]
+ordersForm = "orders" .: listOf orderForm (Just def)
+ where
+ def =
+ [ Order "Milk" 2
+ , Order "Bread" 3
+ ]
+
+
+--------------------------------------------------------------------------------
+ordersView :: View H.Html -> H.Html
+ordersView view = do
+ label "orders.indices" view "(Usually hidden) Indices: "
+ inputText "orders.indices" view
+ H.br
+
+ mapM_ orderView $ listSubViews "orders" view
+
+
+--------------------------------------------------------------------------------
+site :: Snap.Snap ()
+site = do
+ r <- runForm "test" ordersForm
+ case r of
+ (view, Nothing) -> do
+ let view' = fmap H.toHtml view
+ Snap.blaze $ form view' "/" $ do
+ ordersView view'
+ H.br
+ inputSubmit "Submit"
+ (_, Just order) ->
+ Snap.blaze $ do
+ H.h1 "OK"
+ H.toHtml $ show order
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = Snap.httpServe Snap.defaultConfig site

0 comments on commit 5068c0b

Please sign in to comment.