From 6556deffdd0be0bfa300e00419916a93f2885f5f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Jun 2011 08:47:45 +0300 Subject: [PATCH] Removed hellowidget --- hellowidget.hs | 173 ------------------------------------------------- 1 file changed, 173 deletions(-) delete mode 100644 hellowidget.hs diff --git a/hellowidget.hs b/hellowidget.hs deleted file mode 100644 index dc52933a..00000000 --- a/hellowidget.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} -import Yesod.Dispatch (mkYesod, parseRoutes, toWaiApp) -import Yesod.Widget -import Yesod.Helpers.Static -import Yesod.Form.Jquery -import Yesod.Form.Core -import Yesod.Form -import Yesod.Json -import Yesod.Handler (GHandler) -import Yesod.Content (RepJson, typeByExt) -import Text.Hamlet (hamlet) -import Text.Cassius (cassius) -import Yesod.Core (Yesod (approot, addStaticContent, defaultLayout), YesodSite (..)) -import Text.Blaze (string) -import Data.Monoid -import Yesod.Form.Nic -import Control.Applicative -import qualified Data.ByteString.Lazy as L -import System.Directory -import Control.Monad.Trans.Class -import Data.Default -import Control.Monad.IO.Class (liftIO) -import Network.Wai.Handler.Warp (run) -import Data.JSON.Types -import Data.Text.Lazy (pack) - -data HW = HW { hwStatic :: Static } -mkYesod "HW" [$parseRoutes| -/ RootR GET -/form FormR -/static StaticR Static hwStatic -/autocomplete AutoCompleteR GET -/customform CustomFormR GET -|] -instance Yesod HW where - approot _ = "" - addStaticContent ext _ content = do - let fn = (base64md5 content) ++ '.' : ext - liftIO $ createDirectoryIfMissing True "static/tmp" - liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - -type Handler = GHandler HW HW - -instance YesodNic HW -instance YesodJquery HW where - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness" -wrapper h = [$hamlet| -#wrapper ^h^ -%footer Brought to you by Yesod Widgets™ -|] -getRootR = defaultLayout $ wrapper $ do - i <- newIdent - setTitle $ string "Hello Widgets" - addCassius [$cassius| -#{i} - color: red -|] - addStylesheet $ StaticR $ StaticRoute ["style.css"] [] - addStylesheetRemote "http://localhost:3000/static/style2.css" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScript $ StaticR $ StaticRoute ["script.js"] [] - addHamlet [$hamlet| -%h1#{i} Welcome to my first widget!!! -%p - %a!href=@RootR@ Recursive link. -%p - %a!href=@FormR@ Check out the form. -%p - %a!href=@CustomFormR@ Custom form arrangement. -%p.noscript Your script did not load. :( -|] - addHtmlHead [$hamlet|%meta!keywords=haskell|] - -handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,) - <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing - <*> stringField ("Another field") (Just "some default text") - <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) - <*> jqueryDayField def - { jdsChangeMonth = True - , jdsChangeYear = True - , jdsYearRange = "1900:c+10" - , jdsNumberOfMonths = Right (2, 3) - } ("A day field") Nothing - <*> timeField ("A time field") Nothing - <*> boolField FormFieldSettings - { ffsLabel = "A checkbox" - , ffsTooltip = "" - , ffsId = Nothing - , ffsName = Nothing - } (Just False) - <*> jqueryAutocompleteField AutoCompleteR - (FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing - <*> nicHtmlField ("HTML") - (Just $ string "You can put rich text here") - <*> maybeEmailField ("An e-mail addres") Nothing - <*> maybeTextareaField "A text area" Nothing - <*> maybeFileField "Any file" - <*> maybePasswordField "Enter a password" Nothing - let (mhtml, mfile) = case res of - FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y) - _ -> (Nothing, Nothing) - let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x - _ -> Nothing - defaultLayout $ do - addCassius [$cassius| -.tooltip - color: #666 - font-style: italic -|] - addCassius [$cassius| -textarea.html - width: 300px - height: 150px -|] - addWidget [$hamlet| -$maybe formFailures.res failures - %ul.errors - $forall failures f - %li $f$ -%form!method=post!enctype=$enctype$ - $hidden$ - %table - ^form^ - %tr - %td!colspan=2 - %input!type=submit - $maybe mhtml html - $html$ - $maybe txt t - $t$ - $maybe mfile f - $show.f$ -|] - setTitle $ string "Form" - -main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= run 3000 - -getAutoCompleteR :: Handler RepJson -getAutoCompleteR = do - term <- runFormGet' $ stringInput "term" - jsonToRepJson $ ValueArray - [ ValueAtom $ AtomText $ pack $ term ++ "foo" - , ValueAtom $ AtomText $ pack $ term ++ "bar" - , ValueAtom $ AtomText $ pack $ term ++ "baz" - ] - -data Person = Person String Int -getCustomFormR = do - let customForm = GForm $ do - (a1, [b1], c1) <- deform $ stringInput "name" - (a2, [b2], c2) <- deform $ intInput "age" - let b = do - b1' <- extractBody b1 - b2' <- extractBody b2 - addHamlet [$hamlet| -%p This is a custom layout. -%h1 Name Follows! -%p ^b1'^ -%p Age: ^b2'^ -|] - return (Person <$> a1 <*> a2, b , c1 `mappend` c2) - (_, wform, enctype) <- runFormGet customForm - defaultLayout $ do - form <- extractBody wform - addHamlet [$hamlet| -%form - ^form^ - %div - %input!type=submit -|]