packages feed

yesod-bootstrap 0.1.0.0 → 0.2

raw patch · 4 files changed

+264/−9 lines, 4 filesdep +yamldep ~yesod-markdown

Dependencies added: yaml

Dependency ranges changed: yesod-markdown

Files

src/Yesod/Bootstrap.hs view
@@ -13,7 +13,10 @@ import Control.Monad.Writer.Class import Control.Monad.Writer.Strict import qualified Data.List as List+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as HA import Data.Function (on)+import Data.String (IsString(..))  data Context = Success | Info | Warning | Danger | Default | Primary | Link | Error data Size = ExtraSmall | Small | Medium | Large@@ -34,12 +37,36 @@ span_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () span_ attrs inner = [whamlet|<span *{mkStrAttrs attrs}>^{inner}|] +strong_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+strong_ attrs inner = [whamlet|<strong *{mkStrAttrs attrs}>^{inner}|]++em_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+em_ attrs inner = [whamlet|<em *{mkStrAttrs attrs}>^{inner}|]++s_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+s_ attrs inner = [whamlet|<s *{mkStrAttrs attrs}>^{inner}|]++nav_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+nav_ attrs inner = [whamlet|<nav *{mkStrAttrs attrs}>^{inner}|]++form_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+form_ attrs inner = [whamlet|<form *{mkStrAttrs attrs}>^{inner}|]++script_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+script_ attrs inner = [whamlet|<script *{mkStrAttrs attrs}>^{inner}|]+ label_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () label_ attrs inner = [whamlet|<label *{mkStrAttrs attrs}>^{inner}|] +pre_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+pre_ attrs inner = [whamlet|<pre *{mkStrAttrs attrs}>^{inner}|]+ input_ :: [(Text,Text)] -> WidgetT site IO () input_ attrs = [whamlet|<input *{mkStrAttrs attrs}>|] +hr_ :: [(Text,Text)] -> WidgetT site IO ()+hr_ attrs = [whamlet|<hr *{mkStrAttrs attrs}>|]+ img_ :: [(Text,Text)] -> WidgetT site IO () img_ attrs = [whamlet|<img *{mkStrAttrs attrs}>|] @@ -70,12 +97,30 @@ ul_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () ul_ attrs inner = [whamlet|<ul *{mkStrAttrs attrs}>^{inner}|] +ol_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+ol_ attrs inner = [whamlet|<ol *{mkStrAttrs attrs}>^{inner}|]+ li_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () li_ attrs inner = [whamlet|<li *{mkStrAttrs attrs}>^{inner}|] +small_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+small_ attrs inner = [whamlet|<small *{mkStrAttrs attrs}>^{inner}|]++i_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+i_ attrs inner = [whamlet|<i *{mkStrAttrs attrs}>^{inner}|]+ a_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () a_ attrs inner = [whamlet|<a *{mkStrAttrs attrs}>^{inner}|] +audio_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+audio_ attrs inner = [whamlet|<audio *{mkStrAttrs attrs}>^{inner}|]++source_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+source_ attrs inner = [whamlet|<source *{mkStrAttrs attrs}>^{inner}|]++anchor :: Route site -> WidgetT site IO () -> WidgetT site IO ()+anchor route inner = [whamlet|<a href="@{route}">^{inner}|]+ button_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO () button_ attrs inner = [whamlet|<button *{mkStrAttrs attrs}>^{inner}|] @@ -98,6 +143,12 @@ alert :: Context -> WidgetT site IO () -> WidgetT site IO () alert ctx = div_ [("class","alert alert-" <> contextName ctx)] +alertHtml :: Context -> Html -> Html+alertHtml ctx inner = H.div H.! HA.class_ (fromString $ Text.unpack $ "alert alert-" <> contextName ctx) $ inner++caret :: WidgetT site IO ()+caret = span_ [("class","caret")] mempty+ glyphicon :: Text -> WidgetT site IO () glyphicon s = span_ [("class","glyphicon glyphicon-" <> s)] mempty @@ -122,6 +173,10 @@ helpBlock :: WidgetT site IO () -> WidgetT site IO () helpBlock = div_ [("class","help-block")] +button :: Context -> Size -> WidgetT site IO () -> WidgetT site IO ()+button ctx size inner = do+  button_ [("class","btn btn-" <> contextName ctx <> " btn-" <> colSizeShortName size)] inner+ anchorButton :: Context -> Route site -> WidgetT site IO () -> WidgetT site IO () anchorButton ctx route inner = do   render <- getUrlRender@@ -165,7 +220,76 @@   Primary -> "primary"   Link -> "link"   Error -> "error"+  Danger -> "danger" +data NavbarTheme = NavbarDefault | NavbarInverse | NavbarOtherTheme Text+data NavbarPosition = NavbarStandard | NavbarStaticTop | NavbarFixedTop+data NavbarItem site +  = NavbarLink (Route site) (WidgetT site IO ())+  | NavbarDropdown (WidgetT site IO ()) [NavbarDropdownItem site]++data NavbarDropdownItem site +  = NavbarDropdownLink (Route site) (WidgetT site IO ())+  | NavbarDropdownHeader (WidgetT site IO ())+  | NavbarDropdownSeparator++navbar :: +     NavbarTheme+  -> NavbarPosition +  -> Route site +  -> WidgetT site IO ()+  -> [NavbarItem site]+  -> [NavbarItem site]+  -> WidgetT site IO ()+navbar theme pos headerRoute headerContent items rightItems = do+  navbarId <- newIdent+  render <- getUrlRender+  nav_ [("class","navbar " <> themeClass <> " " <> posClass)] $ do+    div_ [("class",containerClass)] $ do+      div_ [("class", "navbar-header")] $ do+        button_ [ ("class", "navbar-toggle collapsed"),("type","button")+                , ("data-toggle", "collapse"), ("aria-expanded", "false")+                , ("aria-controls", navbarId),("data-target", "#" <> navbarId)+                ] $ do+          span_ [("class","sr-only")] $ tw "Toggle Navigation"+          replicateM_ 3 $ span_ [("class","icon-bar")] mempty+        a_ [("href", render headerRoute),("class","navbar-brand")] headerContent+      div_ [("class","navbar-collapse collapse"), ("id", navbarId)] $ do+        ul_ [("class","nav navbar-nav")] $ mapM_ navbarItem items+        ul_ [("class","nav navbar-nav navbar-right")] $ mapM_ navbarItem rightItems+  where +  themeClass = case theme of+    NavbarDefault -> "navbar-default" +    NavbarInverse -> "navbar-inverse" +    NavbarOtherTheme t -> "navbar-" <> t+  posClass = case pos of+    NavbarStandard -> ""+    NavbarStaticTop -> "navbar-static-top"+    NavbarFixedTop -> "navbar-fixed-top"+  containerClass = case pos of+    NavbarStandard -> "container-fluid"+    NavbarStaticTop -> "container"+    NavbarFixedTop -> "container"+  +navbarItem :: NavbarItem site -> WidgetT site IO ()+navbarItem item = do+  render <- getUrlRender+  li_ [] $ case item of+    NavbarLink route name -> anchor route name+    NavbarDropdown name children -> do+      a_ [ ("class","dropdown-toggle"), ("href", "#")+         , ("role", "button"), ("data-toggle", "dropdown")+         ] name+      ul_ [("class","dropdown-menu")] $ mapM_ navbarDropdownItem children++navbarDropdownItem :: NavbarDropdownItem site -> WidgetT site IO ()+navbarDropdownItem item = do+  render <- getUrlRender+  case item of+    NavbarDropdownLink route name -> li_ [] $ anchor route name+    NavbarDropdownHeader name -> li_ [("class","dropdown-header")] name+    NavbarDropdownSeparator -> li_ [("class","separator"),("role","divider")] mempty+ -- Stands for text widget tw :: Text -> WidgetT site IO () tw = toWidget . toHtml @@ -193,9 +317,24 @@           ToggleStylePill -> "nav-pills"     ul_ [("class","nav " <> styleText),("role","tablist")] nav     div_ [("class","tab-content")] bodies-  where tellFst a = tell (a,mempty)-        tellSnd b = tell (mempty,b)-        addClass :: Text -> [(Text,Text)] -> [(Text,Text)]-        addClass klass attrs = case List.lookup "class" attrs of-          Nothing -> ("class",klass) : attrs-          Just c -> ("class",c <> " " <> klass) : List.deleteBy ((==) `on` fst) ("class","") attrs+  where +  tellFst a = tell (a,mempty)+  tellSnd b = tell (mempty,b)+  addClass :: Text -> [(Text,Text)] -> [(Text,Text)]+  addClass klass attrs = case List.lookup "class" attrs of+    Nothing -> ("class",klass) : attrs+    Just c -> ("class",c <> " " <> klass) : List.deleteBy ((==) `on` fst) ("class","") attrs++listGroupLinked :: [(Route site,WidgetT site IO ())] -> WidgetT site IO ()+listGroupLinked items = do+  render <- getUrlRender+  div_ [("class","list-group")] $ forM_ items $ \(route,name) -> do+    a_ [("href",render route),("class","list-group-item")] name++breadcrumbsList :: [(Route site,WidgetT site IO ())] -> WidgetT site IO ()+breadcrumbsList allCrumbs = case reverse allCrumbs of+  (_,lastCrumbWidget):crumbs -> ol_ [("class","breadcrumb")] $ do+    forM_ (reverse crumbs) $ \(route,name) -> li_ [] $ anchor route name+    li_ [("class","active")] lastCrumbWidget+  [] -> mempty+
src/Yesod/Form/Generic.hs view
@@ -28,6 +28,11 @@     (x, y, ints'', z) <- g mr env ints'     return (a <*> x, b <> y, ints'', c <> z) +instance Monoid w => MonadTrans (GForm w) where+  lift f = GForm $ \_ _ ints -> do+    x <- f+    return (FormSuccess x, mempty, ints, mempty)+ mghelper :: MonadHandler m          => Enctype           -> ([Text] -> [FileInfo] -> m (FormResult a)) -- ^ parser@@ -70,6 +75,14 @@   put ints'   tell enc   return (a, w)++gFormToFormCsrf :: (Monad m, HandlerSite m ~ site)+                => GForm (WidgetT site IO ()) m a+                -> Html+                -> MForm m (FormResult a, (WidgetT site IO ()))+gFormToFormCsrf g h = do+  (r,w) <- gFormToForm g+  return (r,toWidget h <> w)  monoidToGForm :: Monad m => w -> GForm w m () monoidToGForm w = formToGForm $ return (FormSuccess (), w)
src/Yesod/Form/Generic/Bootstrap.hs view
@@ -8,6 +8,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Text.Email.Validate as Email+import qualified Data.Yaml as Yaml import Text.Shakespeare.I18N (RenderMessage) import Yesod.Bootstrap import Data.Maybe@@ -50,7 +51,9 @@ markdownToHtmlCustom :: Markdown -> Html markdownToHtmlCustom m@(Markdown t)   | m == mempty = preEscapedToHtml ("<span class=\"text-muted\">Preview</span>" :: Text)-  | otherwise   = markdownToHtml (Markdown (Text.filter (/= '\r') t))+  | otherwise   = case markdownToHtml (Markdown (Text.filter (/= '\r') t)) of+      Left _ -> preEscapedToHtml ("<span class=\"text-muted\">Could not render</span>" :: Text)+      Right a -> a  data FieldConfig m a = FieldConfig   { _fcLabel :: Maybe (WidgetT (HandlerSite m) IO ())@@ -99,6 +102,57 @@       glyphiconFeedback "remove"       helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs +class YesodTypeahead site where+  routeTypeaheadJs :: site -> Route site+  routeTypeaheadCss :: site -> Route site++-- The result from the route is expected to be a JSON array. Also, the route+-- is expected to respond to a POST request with the body as the text we are+-- searching for.+typeahead :: (YesodTypeahead site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => Route site -> FieldConfig m Text -> GForm (WidgetT site IO ()) m Text+typeahead route config = ghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> do+  inputId <- newIdent+  let baseAttrs = [("id",inputId),("class","form-control"),("name",name),("type","text")]+      addReadonly = if _fcReadonly config then (("readonly","readonly"):) else id+      attrs = addReadonly baseAttrs+      baseInput t = do+        whenMaybe (_fcLabel config) controlLabel+        input_ attrs+  yesod <- getYesod+  addStylesheet $ routeTypeaheadCss yesod+  addScript $ routeTypeaheadJs yesod+  typeaheadJs route inputId +  case res of+    FormMissing -> formGroup $ baseInput $ maybe "" display (_fcValue config)+    FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do+      baseInput (display a)+    FormFailure errs -> formGroupFeedback Error $ do+      baseInput $ fromMaybe "" $ listToMaybe vals+      glyphiconFeedback "remove"+      helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs+  where parser = (gparseHelper (return . Right) Nothing)+        display = id++typeaheadJs :: Route site -> Text -> WidgetT site IO ()+typeaheadJs route inputId = toWidget [julius|+$().ready(function(){+  var serNum = $('##{rawJS inputId}');+  serNum.typeahead({+    source: function (query, process) {+      return $.post('@{route}', query, function(data){+        return process(data);+      });+    },+    items: 'all',+    minLength: 2,+    afterSelect: function(ser) { +      // serNum.closest('form').submit();+    }+  });     +});+|]+ simpleCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)   => Text -- ^ input type   -> ([Text] -> [FileInfo] -> m (FormResult (Maybe a)))@@ -161,6 +215,54 @@ class YesodUpload site where   uploadDirectory :: site -> String   uploadRoute :: UploadFilename -> Route site++yaml :: (FromJSON a, ToJSON a, HandlerSite m ~ site, MonadHandler m, RenderMessage site FormMessage) +  => a -> FieldConfig m a -> GForm (WidgetT site IO ()) m a+yaml example c = ghelper UrlEncoded (fullValidate (gparseHelper (return . mapLeft (SomeMessage . Text.pack) . Yaml.decodeEither . Text.encodeUtf8) Nothing) (_fcValidate c))+  $ \name vals res -> do+    preId    <- newIdent+    buttonId <- newIdent+    yamlJs preId buttonId+    let thePre = pre_ [("id",preId),("style","display:none")] $ tw $ yamlEncodeText example+        baseAttrs = [("class","form-control"),("name",name),("rows","5")]+        addReadonly = if (_fcReadonly c) then (("readonly","readonly"):) else id+        attrs = addReadonly baseAttrs+        baseInput t = do+          whenMaybe (_fcLabel c) controlLabel+          textarea_ attrs (tw t)+    case res of+      FormMissing -> formGroup $ do+        baseInput $ maybe "" yamlEncodeText (_fcValue c)+        button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"+        thePre+      FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do+        baseInput (yamlEncodeText a)+        button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"+        thePre+      FormFailure errs -> formGroupFeedback Error $ do+        baseInput $ fromMaybe "" $ listToMaybe vals+        glyphiconFeedback "remove"+        helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs+        button_ [("class","btn btn-link"),("id",buttonId),("type","button")] $ tw "Show Example"+        thePre+  where yamlEncodeText = Text.decodeUtf8 . Yaml.encode+  +yamlJs :: Text -> Text -> WidgetT site IO ()+yamlJs preId buttonId = toWidget [julius|+$().ready(function(){+  var showing = false;+  var button = $('##{rawJS buttonId}');+  var pre = $('##{rawJS preId}');+  button.click(function(){+    showing = !showing;+    pre.slideToggle();+    if(showing)+      button.text("Hide Example");+    else+      button.text("Show Example");+  });+});+|]  markdown :: (YesodMarkdownRender site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)   => FieldConfig m Markdown -> GForm (WidgetT site IO ()) m Markdown
yesod-bootstrap.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                yesod-bootstrap-version:             0.1.0.0+version:             0.2 synopsis:            Bootstrap widgets for yesod -- description:          license:             MIT@@ -44,9 +44,10 @@                      , either                      , MonadRandom                      , persistent-                     , yesod-markdown+                     , yesod-markdown >= 0.10.0                      , conduit                      , conduit-extra                      , blaze-markup+                     , yaml   hs-source-dirs:      src   default-language:    Haskell2010