packages feed

yesod-bootstrap (empty) → 0.1.0.0

raw patch · 7 files changed

+799/−0 lines, 7 filesdep +MonadRandomdep +basedep +blaze-htmlsetup-changed

Dependencies added: MonadRandom, base, blaze-html, blaze-markup, conduit, conduit-extra, containers, either, email-validate, lens-family-core, lens-family-th, mtl, persistent, shakespeare, text, time, transformers, yesod-core, yesod-form, yesod-markdown

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Andrew Martin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/Bootstrap.hs view
@@ -0,0 +1,201 @@+module Yesod.Bootstrap where++import Prelude hiding (div)+import Yesod.Core+import Yesod.Core.Widget+import Yesod.Core.Handler+import Data.Text (Text)+import Data.List+import Data.Monoid+import Control.Monad+import Text.Blaze.Html (toHtml)+import qualified Data.Text as Text+import Control.Monad.Writer.Class+import Control.Monad.Writer.Strict+import qualified Data.List as List+import Data.Function (on)++data Context = Success | Info | Warning | Danger | Default | Primary | Link | Error+data Size = ExtraSmall | Small | Medium | Large+data ColSize = ColSize Size Int+data Flow = Block | Inline+data Panel site = Panel +  { panelTitle :: (WidgetT site IO ()) +  , panelBody :: (WidgetT site IO ())+  , panelContext :: Context+  }++basicPanel :: Text -> WidgetT site IO () -> Panel site+basicPanel t c = Panel (tw t) c Default++div_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+div_ attrs inner = [whamlet|<div *{mkStrAttrs attrs}>^{inner}|]++span_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+span_ attrs inner = [whamlet|<span *{mkStrAttrs attrs}>^{inner}|]++label_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+label_ attrs inner = [whamlet|<label *{mkStrAttrs attrs}>^{inner}|]++input_ :: [(Text,Text)] -> WidgetT site IO ()+input_ attrs = [whamlet|<input *{mkStrAttrs attrs}>|]++img_ :: [(Text,Text)] -> WidgetT site IO ()+img_ attrs = [whamlet|<img *{mkStrAttrs attrs}>|]++textarea_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+textarea_ attrs inner = [whamlet|<textarea *{mkStrAttrs attrs}>^{inner}|]++h1_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h1_ attrs inner = [whamlet|<h1 *{mkStrAttrs attrs}>^{inner}|]++h2_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h2_ attrs inner = [whamlet|<h2 *{mkStrAttrs attrs}>^{inner}|]++h3_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h3_ attrs inner = [whamlet|<h3 *{mkStrAttrs attrs}>^{inner}|]++h4_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h4_ attrs inner = [whamlet|<h4 *{mkStrAttrs attrs}>^{inner}|]++h5_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h5_ attrs inner = [whamlet|<h5 *{mkStrAttrs attrs}>^{inner}|]++h6_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+h6_ attrs inner = [whamlet|<h6 *{mkStrAttrs attrs}>^{inner}|]++p_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+p_ attrs inner = [whamlet|<p *{mkStrAttrs attrs}>^{inner}|]++ul_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+ul_ attrs inner = [whamlet|<ul *{mkStrAttrs attrs}>^{inner}|]++li_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+li_ attrs inner = [whamlet|<li *{mkStrAttrs attrs}>^{inner}|]++a_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+a_ attrs inner = [whamlet|<a *{mkStrAttrs attrs}>^{inner}|]++button_ :: [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()+button_ attrs inner = [whamlet|<button *{mkStrAttrs attrs}>^{inner}|]++mkStrAttrs :: [(Text,Text)] -> [(String,String)]+mkStrAttrs = map $ \(a,b) -> (Text.unpack a, Text.unpack b)++row :: WidgetT site IO () -> WidgetT site IO ()+row = div_ [("class","row")]++container :: WidgetT site IO () -> WidgetT site IO ()+container = div_ [("class","container")]++col :: [ColSize] -> WidgetT site IO () -> WidgetT site IO ()+col cs = div_ [("class", Text.intercalate " " (map mkAttr cs))]+  where mkAttr (ColSize s n) = Text.concat ["col-", colSizeShortName s, "-", Text.pack (show n)]++checkbox :: WidgetT site IO () -> WidgetT site IO ()+checkbox = div_ [("class","checkbox")]++alert :: Context -> WidgetT site IO () -> WidgetT site IO ()+alert ctx = div_ [("class","alert alert-" <> contextName ctx)]++glyphicon :: Text -> WidgetT site IO ()+glyphicon s = span_ [("class","glyphicon glyphicon-" <> s)] mempty++glyphiconFeedback :: Text -> WidgetT site IO ()+glyphiconFeedback s = span_ [("class",Text.concat ["glyphicon glyphicon-", s, " form-control-feedback"])] mempty++formGroup :: WidgetT site IO () -> WidgetT site IO ()+formGroup = div_ [("class","form-group")]++formGroupFeedback :: Context -> WidgetT site IO () -> WidgetT site IO ()+formGroupFeedback ctx = div_ [("class",Text.concat ["form-group has-", contextName ctx, " has-feedback"])]++inputGroup :: WidgetT site IO () -> WidgetT site IO ()+inputGroup = div_ [("class","input-group")] ++inputGroupAddon :: WidgetT site IO () -> WidgetT site IO ()+inputGroupAddon = span_ [("class","input-group-addon")] ++controlLabel :: WidgetT site IO () -> WidgetT site IO ()+controlLabel = label_ [("class","control-label")]++helpBlock :: WidgetT site IO () -> WidgetT site IO ()+helpBlock = div_ [("class","help-block")]++anchorButton :: Context -> Route site -> WidgetT site IO () -> WidgetT site IO ()+anchorButton ctx route inner = do+  render <- getUrlRender+  a_ [("href",render route),("class","btn btn-" <> contextName ctx)] inner++label :: Context -> WidgetT site IO () -> WidgetT site IO ()+label ctx = span_ [("class","label label-" <> contextName ctx)]++badge :: WidgetT site IO () -> WidgetT site IO ()+badge = span_ [("class","badge")]++panelAccordion :: [Panel site] -> WidgetT site IO ()+panelAccordion tcs = do +  groupId <- newIdent +  div_ [("class","panel-group"),("id",groupId),("role","tablist")] $ do+    forM_ (zip [1..] tcs) $ \(i,Panel title content ctx) -> do+      headingId <- newIdent+      panelId <- newIdent+      div_ [("class","panel panel-" <> contextName ctx)] $ do+        div_ [("class", "panel-heading"),("role","tab"),("id",headingId)] $ do+          h4_ [("class","panel-title")] $ do+            a_ [("href","#" <> panelId),("role","button"),("data-toggle","collapse"),("data-parent","#" <> groupId)] $ do+              title+        div_ [("id",panelId),("class","panel-collapse collapse" <> (if i == 1 then " in" else "")),("role","tabpanel"),("aria-labelledby",headingId)] $ do+          div_ [("class","panel-body")] $ do+            content++colSizeShortName :: Size -> Text+colSizeShortName s = case s of+  ExtraSmall -> "xs" +  Small -> "sm" +  Medium -> "md" +  Large -> "lg" ++contextName :: Context -> Text+contextName c = case c of +  Success -> "success"+  Info -> "info"+  Warning -> "warning"+  Default -> "default"+  Primary -> "primary"+  Link -> "link"+  Error -> "error"++-- Stands for text widget+tw :: Text -> WidgetT site IO ()+tw = toWidget . toHtml ++-- Togglable tabs+data ToggleTab site = ToggleSection Text (WidgetT site IO ()) | ToggleDropdown Text [(Text,WidgetT site IO ())]+data ToggleStyle = ToggleStyleTab | ToggleStylePill++togglableTabs :: ToggleStyle -> [ToggleTab site] -> WidgetT site IO ()+togglableTabs s tabs = do+  (nav,bodies) <- execWriterT $ forM_ (zip [1..] tabs) $ \(i,tab) -> case tab of+    ToggleSection title body -> do+      theId <- lift newIdent+      let tabAAttrs = [("role","tab"),("href","#" <> theId),("data-toggle","tab")]+          tabLiAttrs = (if isFirst then addClass "active" else id) [("role","presentation")]+          paneClasses = (if isFirst then addClass "active" else id)+            [("class","tab-pane"),("role","tabpanel"),("id",theId)]+          isFirst = (i == (1 :: Int))+      tellFst $ li_ tabLiAttrs $ a_ tabAAttrs $ tw title+      tellSnd $ div_ paneClasses body+    _ -> error "figure this out"+  div_ [] $ do+    let styleText = case s of+          ToggleStyleTab -> "nav-tabs"+          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
+ src/Yesod/Form/Generic.hs view
@@ -0,0 +1,77 @@+module Yesod.Form.Generic where++import Yesod.Core+import Yesod.Form+import Data.Text (Text)+import Control.Monad+import Control.Applicative+import Data.Monoid+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)+import Data.Maybe+import qualified Data.Map as Map++newtype GForm w m a = GForm +  { unGForm :: (HandlerSite m, [Text])+            -> Maybe (Env, FileEnv)+            -> Ints+            -> m (FormResult a, w, Ints, Enctype)+  }++instance Monad m => Functor (GForm w m) where+  fmap f (GForm a) = GForm $ \x y z -> liftM go $ a x y z+    where go (w, x, y, z) = (fmap f w, x, y, z)++instance (Monad m, Monoid w) => Applicative (GForm w m) where+  pure x = GForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)+  (GForm f) <*> (GForm g) = GForm $ \mr env ints -> do+    (a, b, ints', c) <- f mr env ints+    (x, y, ints'', z) <- g mr env ints'+    return (a <*> x, b <> y, ints'', c <> z)++mghelper :: MonadHandler m+         => Enctype +         -> ([Text] -> [FileInfo] -> m (FormResult a)) -- ^ parser+         -> (Text -> [Text] -> FormResult a -> w) -- ^ function for building output, needs name and vals+         -> MForm m (FormResult a, w)+mghelper enctype parse buildOutput = do+  tell enctype+  mp <- askParams+  name <- newFormIdent +  case mp of+    Nothing -> return (FormMissing, buildOutput name [] FormMissing)+    Just p -> do+      mfs <- askFiles+      let mvals = fromMaybe [] $ Map.lookup name p+          files = fromMaybe [] $ mfs >>= Map.lookup name+      res <- lift $ parse mvals files+      return (res, buildOutput name mvals res)++ghelper :: MonadHandler m+        => Enctype +        -> ([Text] -> [FileInfo] -> m (FormResult a)) -- ^ parser+        -> (Text -> [Text] -> FormResult a -> w) -- ^ function for building output, needs name+        -> GForm w m a+ghelper a b c = formToGForm (mghelper a b c)++formToGForm :: (HandlerSite m ~ site, Monad m)+            => MForm m (FormResult a, w)+            -> GForm w m a+formToGForm form = GForm $ \(site, langs) env ints -> do+  ((a, w), ints', enc) <- runRWST form (env, site, langs) ints+  return (a, w, ints', enc)++gFormToForm :: (Monad m, HandlerSite m ~ site)+            => GForm w m a+            -> MForm m (FormResult a, w)+gFormToForm (GForm gform) = do+  ints <- get+  (env, site, langs) <- ask+  (a, w, ints', enc) <- lift $ gform (site, langs) env ints+  put ints'+  tell enc+  return (a, w)++monoidToGForm :: Monad m => w -> GForm w m ()+monoidToGForm w = formToGForm $ return (FormSuccess (), w)++
+ src/Yesod/Form/Generic/Bootstrap.hs view
@@ -0,0 +1,438 @@+module Yesod.Form.Generic.Bootstrap where++import Yesod.Form+import Yesod.Form.Generic+import Yesod.Core+import Yesod.Core.Widget+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Text.Email.Validate as Email+import Text.Shakespeare.I18N (RenderMessage)+import Yesod.Bootstrap+import Data.Maybe+import Text.Read (readMaybe)+import Control.Applicative+import Control.Monad+import Data.Time (Day)+import Data.Monoid+import Lens.Family+import Lens.Family2.TH+import Text.Julius (rawJS)+import Debug.Trace+import Data.Either.Combinators+import Data.String+import Control.Monad.Random+import Database.Persist (PersistField)+import Database.Persist.Sql (PersistFieldSql)+import Yesod.Markdown+import Data.Conduit+import Data.Conduit.Lazy (lazyConsume)+import qualified Data.Conduit.Text as Conduit+import Text.Blaze.Html (preEscapedToHtml)+import Yesod.Form.Generic.Bootstrap.Internal ++class YesodMarkdownRender site where+  markdownRenderSubsite :: Route MarkdownRender -> Route site++instance YesodSubDispatch MarkdownRender (HandlerT master IO) where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesMarkdownRender)++getMarkdownRender :: a -> MarkdownRender+getMarkdownRender = const MarkdownRender++postMarkdownRenderR :: HandlerT MarkdownRender (HandlerT site IO) Html+postMarkdownRenderR = do+  ts <- lazyConsume $ rawRequestBody =$= Conduit.decode Conduit.utf8+  let mkd = Markdown $ Text.concat ts+  return $ markdownToHtmlCustom mkd++markdownToHtmlCustom :: Markdown -> Html+markdownToHtmlCustom m@(Markdown t)+  | m == mempty = preEscapedToHtml ("<span class=\"text-muted\">Preview</span>" :: Text)+  | otherwise   = markdownToHtml (Markdown (Text.filter (/= '\r') t))++data FieldConfig m a = FieldConfig+  { _fcLabel :: Maybe (WidgetT (HandlerSite m) IO ())+  , _fcPlaceholder :: Maybe (SomeMessage (HandlerSite m))+  , _fcTooltip :: Maybe (SomeMessage (HandlerSite m))+  , _fcId :: Maybe Text+  , _fcName :: Maybe Text+  , _fcValue :: Maybe a+  , _fcReadonly :: Bool+  , _fcValidate :: a -> m (Either (SomeMessage (HandlerSite m)) a)+  }+makeLenses ''FieldConfig++instance Monad m => Monoid (FieldConfig m a) where+  mempty = FieldConfig Nothing Nothing Nothing Nothing Nothing Nothing False (return . Right)+  FieldConfig a1 b1 c1 d1 e1 f1 r1 v1 `mappend` FieldConfig a2 b2 c2 d2 e2 f2 r2 v2 = +    FieldConfig (a2 <|> a1) (b2 <|> b1) (c2 <|> c1) (d2 <|> d1) (e2 <|> e1) (f2 <|> f1) (r1 || r2) +    $ \a -> do+      e <- v1 a+      case e of +        Left err -> return $ Left err+        Right a' -> return $ Right a'++instance Monad m => IsString (FieldConfig m a) where+  fromString s = mempty {_fcLabel = Just (toWidget (toHtml s))}++render :: Monad m => GForm (WidgetT site IO ()) m a -> Html -> MForm m (FormResult a, WidgetT site IO ())+render g h = gFormToForm (monoidToGForm (toWidget h) *> g)++greenOnSuccess :: Bool+greenOnSuccess = False++simple :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => Text -- ^ input type+  -> ([Text] -> [FileInfo] -> m (FormResult a))+  -> (a -> Text)+  -> FieldConfig m a -> GForm (WidgetT site IO ()) m a+simple typ parser display config = ghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> +  let baseInput = labelAndInput (fromMaybe mempty $ _fcLabel config) name typ (_fcReadonly config)+  in 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++simpleCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => Text -- ^ input type+  -> ([Text] -> [FileInfo] -> m (FormResult (Maybe a)))+  -> (Maybe a -> Text)+  -> FieldConfig m (Maybe a) -> GForm (WidgetT site IO ()) m (Maybe a)+simpleCheck typ parser display config = formToGForm $ do+  (checkId, inputId) <- (,) <$> newIdent <*> newIdent+  (checkRes, checkWidget) <- mghelper UrlEncoded (fullValidate (gparseHelper (return . checkBoxParser) (Just False)) (return . Right)) $ \name _vals res -> do+    val <- decipherCheckRes res+    input_ $ boolAttrs [("checked",val)] ++ [("id",checkId),("name",name),("value","yes"),("type","checkbox")]+  (inputRes, inputWidget) <- mghelper UrlEncoded (fullValidate parser (_fcValidate config)) $ \name vals res -> do+    isChecked <- decipherCheckRes checkRes+    let baseInputGroup val = inputGroup $ do+          inputGroupAddon checkWidget+          input_ $ boolAttrs [("readonly", not isChecked)] ++ +            [("id",inputId),("class","form-control"),("type",typ),("name",name),("value",val)]+    case (isChecked,res) of+      (_, FormMissing) -> formGroup $ do+        maybe mempty controlLabel (_fcLabel config)+        baseInputGroup $ maybe "" display (_fcValue config)+      (_, FormSuccess a) -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do+        maybe mempty controlLabel (_fcLabel config)+        baseInputGroup (display a)+      (False,FormFailure errs) -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do+        maybe mempty controlLabel (_fcLabel config)+        baseInputGroup ""+      (True,FormFailure errs) -> formGroupFeedback Error $ do+        maybe mempty controlLabel (_fcLabel config)+        baseInputGroup $ fromMaybe "" $ listToMaybe vals+        glyphiconFeedback "remove"+        helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs+  return ( checkRes `bindFormResult` \b -> if traceShowId b then inputRes else pure Nothing+         , inputWidget <> simpleCheckJs checkId inputId )+  where decipherCheckRes r = case r of+          FormSuccess b -> return b+          FormFailure _ -> permissionDenied "Bootstrap checkbox field somehow failed" +          FormMissing   -> return $ isJust $ join (_fcValue config)++select :: (RenderMessage site FormMessage, Eq a)+  => HandlerT site IO (OptionList a) +  -> FieldConfig (HandlerT site IO) a +  -> GForm (WidgetT site IO ()) (HandlerT site IO) a+select opts c = ghelper UrlEncoded +  (fieldParseToGParse parse) $ \name vals res -> do+    theId <- newIdent +    let r = case res of+              FormSuccess a -> Right a+              FormMissing -> case _fcValue c of+                Nothing -> Left ""+                Just a -> Right a+              FormFailure _ -> Left ""+    formGroup $ do+      whenMaybe (_fcLabel c) controlLabel+      view theId name [("class","form-control")] r True+  where Field parse view enctype = selectField opts++newtype UploadFilename = UploadFilename Text+  deriving (PersistField, PersistFieldSql, Show, Read)++class YesodUpload site where+  uploadDirectory :: site -> String+  uploadRoute :: UploadFilename -> Route site++markdown :: (YesodMarkdownRender site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m Markdown -> GForm (WidgetT site IO ()) m Markdown+markdown c = ghelper UrlEncoded (fullValidate (gparseHelper (return . Right . Markdown . Text.filter (/= '\r')) Nothing) (_fcValidate c)) +  $ \name vals res -> do+    wellId <- newIdent+    inputId <- newIdent+    render <- getUrlRender+    markdownJs wellId inputId (render $ markdownRenderSubsite MarkdownRenderR)+    let theWell = helpBlock . div_ [("class","well well-sm"),("id",wellId)] . toWidget+        baseAttrs = [("class","form-control"),("name",name),("rows","5"),("id",inputId)]+        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 "" unMarkdown (_fcValue c)+        theWell $ markdownToHtmlCustom $ fromMaybe mempty (_fcValue c)+      FormSuccess a -> (if greenOnSuccess then formGroupFeedback Success else formGroup) $ do+        baseInput (unMarkdown a)+        theWell $ markdownToHtmlCustom a+      FormFailure errs -> formGroupFeedback Error $ do+        baseInput $ fromMaybe "" $ listToMaybe vals+        glyphiconFeedback "remove"+        theWell $ markdownToHtmlCustom mempty+        helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs++markdownJs :: Text -> Text -> Text -> WidgetT site IO ()+markdownJs wellId inputId url = toWidget [julius|+$().ready(function(){+  var hasChanged = false;+  var input = $('##{rawJS inputId}');+  var well = $('##{rawJS wellId}');+  var runUpdate = function(){+    if(!hasChanged) return;+    $.ajax({ type: "POST"+           , url: "#{rawJS url}"+           , data: input.val()+           , dataType: 'html'+           , success: function(data) {+               well.html(data);+               hasChanged = false;+             } +           });+  };+  setInterval(runUpdate, 1000);+  input.on('input',function(){+    hasChanged = true;+  });+});+|]++file :: (YesodUpload site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m UploadFilename -> GForm (WidgetT site IO ()) m UploadFilename+file c = ghelper Multipart+  (fullValidate (fileParseHelper (_fcValue c)) (_fcValidate c)) $ \name _vals res -> do+    formGroup $ do+      whenMaybe (_fcLabel c) controlLabel+      input_ [("type","file"),("name",name)] +      case res of+        FormFailure errs -> helpBlock $ ul_ [("class","list-unstyled")] $ mapM_ (li_ [] . tw) errs+        _ -> mempty+      whenMaybe (_fcValue c) $ \filename -> do+        render <- getUrlRender+        helpBlock $ img_ [("width","140"),("src",render $ uploadRoute filename),("class","img-thumbnail")]+    +  +fileParseHelper :: (YesodUpload site, MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => (Maybe UploadFilename) -- ^ If this is Just, then the field is not required.+  -> [Text] -> [FileInfo] -> m (FormResult UploadFilename)+fileParseHelper mdef _ [] = return $ case mdef of+  Nothing -> FormMissing+  Just a -> FormSuccess a+fileParseHelper _ _ (x:_) = do+  app <- getYesod+  name <- liftIO $ moveIt (uploadDirectory app) x+  return (FormSuccess name)++moveIt :: String -> FileInfo -> IO UploadFilename+moveIt dir fi = do+  baseFilename <- randomUpperConsonantText 24+  let ext = snd $ Text.breakOn "." (fileName fi)+      fullFileName = baseFilename <> ext+  fileMove fi $ Text.unpack $ mempty +    <> Text.pack dir +    <> "/" +    <> fullFileName+  return $ UploadFilename fullFileName++randomUpperConsonantText :: Int -> IO Text+randomUpperConsonantText n = id+  $ fmap Text.pack +  $ evalRandIO +  $ replicateM n+  $ uniform allConsonants+  where allConsonants = filter (not . isVowel) ['A'..'Z']++isVowel :: Char -> Bool+isVowel c = case c of+  'a' -> True+  'e' -> True+  'i' -> True+  'o' -> True+  'u' -> True+  'A' -> True+  'E' -> True+  'I' -> True+  'O' -> True+  'U' -> True+  _   -> False++simpleCheckJs :: Text -> Text -> WidgetT site IO ()+simpleCheckJs checkId inputId = toWidget [julius|+$().ready(function(){+  $('##{rawJS checkId}').change(function(){+    var enabled = this.checked;+    var input = $('##{rawJS inputId}');+    if (!enabled) input.val("");+    input.prop('readonly',!enabled);+  });+});+|]++bindFormResult :: FormResult a -> (a -> FormResult b) -> FormResult b+bindFormResult ra f = case ra of+  FormFailure errs -> FormFailure errs+  FormMissing -> FormMissing+  FormSuccess a -> f a++ifA :: Applicative f => f Bool -> f a -> f a -> f a+ifA t c a = g <$> t <*> c <*> a where g b x y = if b then x else y++boolAttrs :: [(Text,Bool)] -> [(Text,Text)]+boolAttrs = map (\t -> (fst t, fst t)) . filter snd++labelAndInput :: WidgetT site IO () -> Text -> Text -> Bool -> Text -> WidgetT site IO ()+labelAndInput labelWidget name typ readonly val = do+  let baseAttrs = [("class","form-control"),("type",typ),("name",name),("value",val)]+      addReadonly = if readonly then (("readonly","readonly"):) else id+  controlLabel labelWidget+  input_ (addReadonly $ baseAttrs)++fieldParseToGParse :: (MonadHandler m)+  => ([Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))+  -> [Text] -> [FileInfo] -> m (FormResult a)+fieldParseToGParse parse ts fs = do+  e <- parse ts fs +  case e of+    Left msg -> do +      langs <- languages+      site  <- getYesod+      return $ FormFailure [renderMessage site langs msg]+    Right Nothing -> return FormMissing+    Right (Just a) -> return (FormSuccess a)++fullValidate :: MonadHandler m +  => ([Text] -> [FileInfo] -> m (FormResult a)) +  -> (a -> m (Either (SomeMessage (HandlerSite m)) a))+  -> [Text] -> [FileInfo] -> m (FormResult a)+fullValidate parser validate ts fs = do+  res <- parser ts fs +  case res of+    FormSuccess a -> do+      e <- validate a+      case e of+        Left msg -> do+          langs <- languages+          site  <- getYesod+          return $ FormFailure [renderMessage site langs msg]+        Right b -> return $ FormSuccess b+    _ -> return res++text :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m Text -> GForm (WidgetT site IO ()) m Text+text = simple "text" +  (gparseHelper (return . Right) Nothing) id++textOpt :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m (Maybe Text) -> GForm (WidgetT site IO ()) m (Maybe Text)+textOpt = simple "text" (gparseHelper (return . Right . Just) (Just Nothing)) (fromMaybe "")++textCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m (Maybe Text) -> GForm (WidgetT site IO ()) m (Maybe Text)+textCheck = simpleCheck "text" +  (gparseHelper (return . Right . Just) Nothing) +  (fromMaybe "")++int :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m Int -> GForm (WidgetT site IO ()) m Int+int = simple "number" (gparseHelper (return . parseInt) Nothing) (Text.pack . show)++intCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m (Maybe Int) -> GForm (WidgetT site IO ()) m (Maybe Int)+intCheck = simpleCheck "number" +  (gparseHelper (return . fmap Just . parseInt) Nothing) +  (maybe "" (Text.pack . show))++day :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m Day -> GForm (WidgetT site IO ()) m Day+day = simple "date" +  (gparseHelper (return . mapLeft SomeMessage . parseDate . Text.unpack) Nothing) +  (Text.pack . show)++dayCheck :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m (Maybe Day) -> GForm (WidgetT site IO ()) m (Maybe Day)+dayCheck = simpleCheck "date" +  (gparseHelper (return . fmap Just . mapLeft SomeMessage . parseDate . Text.unpack) Nothing)+  (maybe "" (Text.pack . show))+-- +-- email :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+--   => WidgetT site IO () -> Maybe Text -> GForm (WidgetT site IO ()) m Text+-- email = simple "email" (gparseHelper textEmailValidate Nothing) id+-- +bool :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+  => FieldConfig m Bool -> GForm (WidgetT site IO ()) m Bool+bool config = ghelper UrlEncoded (fullValidate (gparseHelper (return . checkBoxParser) (Just False)) (_fcValidate config)) $ \name _vals res -> do+  val <- case res of+    FormSuccess b -> return b+    FormFailure _ -> permissionDenied "Bootstrap checkbox field somehow failed" -- should be impossible+    FormMissing   -> return $ fromMaybe False (_fcValue config)+  let applyVal = if val then (("checked","checked"):) else id+  checkbox $ label_ [] $ do +    input_ $ applyVal [("name",name),("value","yes"),("type","checkbox")]+    fromMaybe mempty $ _fcLabel config++checkBoxParser :: Text -> Either (SomeMessage site) Bool+checkBoxParser x = case x of+  "yes" -> Right True +  "on"  -> Right True+  _     -> Right False++textEmailValidate :: Text -> Either FormMessage Text+textEmailValidate t = if Email.isValid (Text.encodeUtf8 t)+  then Right t+  else Left (MsgInvalidEmail t)++submit :: Monad m => Context -> Text -> GForm (WidgetT site IO ()) m ()+submit ctx t = monoidToGForm $ button_ [("type","submit"),("class","btn btn-" <> contextName ctx)] $ tw t++parseInt :: RenderMessage site FormMessage => Text -> Either (SomeMessage site) Int+parseInt t = case readMaybe (Text.unpack t) of+  Nothing -> Left (SomeMessage (MsgInvalidInteger t))+  Just n -> Right n+  +-- specialRight :: a -> Either Text a +-- specialRight = Right++gparseHelper :: (MonadHandler m, HandlerSite m ~ site, RenderMessage site FormMessage)+             => (Text -> m (Either (SomeMessage site) a))+             -> (Maybe a) -- ^ If this is Just, then the field is not required.+             -> [Text] -> [FileInfo] -> m (FormResult a)+gparseHelper _ mdef [] _ = return $ case mdef of+  Nothing -> FormMissing+  Just a -> FormSuccess a+gparseHelper _ mdef ("":_) _ = case mdef of+  Nothing -> do+    langs <- languages+    site <- getYesod+    return $ FormFailure [renderMessage site langs MsgValueRequired]+  Just a -> return (FormSuccess a)+gparseHelper f _ (x:_) _  = do+  e <- f x+  case e of+    Left msg -> do+      langs <- languages+      site <- getYesod+      return $ FormFailure [renderMessage site langs msg]+    Right a -> return (FormSuccess a)++whenMaybe :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenMaybe Nothing _ = pure ()+whenMaybe (Just a) f = f a+
+ src/Yesod/Form/Generic/Bootstrap/Internal.hs view
@@ -0,0 +1,9 @@+module Yesod.Form.Generic.Bootstrap.Internal where++import Yesod.Core++data MarkdownRender = MarkdownRender+mkYesodSubData "MarkdownRender" [parseRoutes|+/markdown/render MarkdownRenderR POST+|]+
+ yesod-bootstrap.cabal view
@@ -0,0 +1,52 @@+-- Initial yesod-bootstrap.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                yesod-bootstrap+version:             0.1.0.0+synopsis:            Bootstrap widgets for yesod+-- description:         +license:             MIT+license-file:        LICENSE+author:              Andrew Martin+maintainer:          andrew.thaddeus@gmail.com+-- copyright:           +category:            Web+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Yesod.Bootstrap+                     , Yesod.Form.Generic+                     , Yesod.Form.Generic.Bootstrap+                     , Yesod.Form.Generic.Bootstrap.Internal+  default-extensions:  QuasiQuotes+                     , GeneralizedNewtypeDeriving+                     , TypeFamilies+                     , MultiParamTypeClasses+                     , FlexibleContexts+                     , FlexibleInstances+                     , OverloadedStrings+                     , TemplateHaskell+  build-depends:       base >=4.7 && <5.0+                     , yesod-core+                     , yesod-form+                     , containers+                     , transformers+                     , shakespeare+                     , text+                     , blaze-html+                     , time+                     , email-validate+                     , lens-family-th+                     , lens-family-core+                     , mtl+                     , either+                     , MonadRandom+                     , persistent+                     , yesod-markdown+                     , conduit+                     , conduit-extra+                     , blaze-markup+  hs-source-dirs:      src+  default-language:    Haskell2010