packages feed

lucid 2.9.9 → 2.9.10

raw patch · 7 files changed

+97/−89 lines, 7 filesdep ~basedep ~blaze-builderdep ~bytestring

Dependency ranges changed: base, blaze-builder, bytestring, containers, hashable, mmorph, mtl, semigroups, text, transformers, unordered-containers

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+## 2.9.10++* Drop GHC-7.8 and older (pre-AMP) support+* Generalise type-signatures to require only `Applicative` or `Functor`,+  when that's enough+ ## 2.9.9  * Add `commuteHtmlT` to commute `HtmlT m a` into `m (HtmlT n a)`.
benchmarks/IO.hs view
@@ -3,12 +3,13 @@  import Lucid import Criterion.Main+import Control.Applicative (Applicative) import Control.Monad (replicateM_) import qualified Data.Text.Lazy as LT import Control.Monad.Trans.Reader (runReader) import Data.Functor.Identity (runIdentity) -lotsOfDivs :: Monad m => Int -> HtmlT m ()+lotsOfDivs :: (Applicative m, Monad m) => Int -> HtmlT m () lotsOfDivs n = body_   $ replicateM_ n   $ div_ "hello world!"
lucid.cabal view
@@ -1,8 +1,16 @@ name:                lucid-version:             2.9.9+version:             2.9.10 synopsis:            Clear to write, read and edit DSL for HTML-description:         Clear to write, read and edit DSL for HTML. See the 'Lucid' module-                     for description and documentation.+description:+  Clear to write, read and edit DSL for HTML.+  .+  * Names are consistent, and do not conflict with base or are keywords (all have suffix @_@)+  .+  * Same combinator can be used for attributes and elements (e.g. 'style_')+  .+  * For more, read <https://chrisdone.com/posts/lucid the blog post>+  .+  See the "Lucid" module for more documentation. homepage:            https://github.com/chrisdone/lucid license:             BSD3 license-file:        LICENSE@@ -13,7 +21,7 @@ build-type:          Simple cabal-version:       >=1.8 extra-source-files:  README.md, CHANGELOG.md-tested-with:         GHC==7.4.2,GHC==7.6.3,GHC==7.8.4,GHC==7.10.3,GHC==8.0.2,GHC==8.2.1+tested-with:         GHC==7.10.3,GHC==8.0.2,GHC==8.2.2,GHC==8.4.1  library   hs-source-dirs:    src/@@ -22,7 +30,7 @@                      Lucid.Base                      Lucid.Html5                      Lucid.Bootstrap-  build-depends:     base >= 4.5 && <5+  build-depends:     base >= 4.8 && <5                    , blaze-builder                    , bytestring                    , containers
src/Lucid.hs view
@@ -141,7 +141,7 @@ -- input_ :: Monad m => [Attribute] -> HtmlT m () -- @ ----- And some attributes share the same name as attributes, so you can+-- And some elements share the same name as attributes, so you can -- also overload them as attributes: -- -- @
src/Lucid/Base.hs view
@@ -106,47 +106,41 @@   hoist f (HtmlT xs) = HtmlT (f xs)  -- | @since 2.9.7-instance (a ~ (),Monad m) => Semigroup (HtmlT m a) where-  (<>) = liftM2 mappend+instance (a ~ (),Applicative m) => Semigroup (HtmlT m a) where+  (<>) = liftA2 (<>)  -- | Monoid is right-associative, a la the 'Builder' in it.-instance (a ~ (),Monad m) => Monoid (HtmlT m a) where-  mempty  = return mempty-  mappend = liftM2 mappend+instance (a ~ (),Applicative m) => Monoid (HtmlT m a) where+  mempty  = pure mempty+  mappend = liftA2 mappend  -- | Based on the monad instance.-instance Monad m => Applicative (HtmlT m) where-  pure a = HtmlT (return (mempty,a))+instance Applicative m => Applicative (HtmlT m) where+  pure a = HtmlT (pure (mempty,a))   {-# INLINE pure #-} -  f <*> x = HtmlT $ do-    ~(g, f') <- runHtmlT f-    ~(h, x') <- runHtmlT x-    return (g <> h, f' x')+  f <*> x = HtmlT $ mk <$> runHtmlT f <*> runHtmlT x+    where mk ~(g, f') ~(h, x') = (g <> h, f' x')   {-# INLINE (<*>) #-} -  m *> n = HtmlT $ do-    ~(g, _) <- runHtmlT m-    ~(h, b) <- runHtmlT n-    return (g <> h, b)+  m *> n = HtmlT $ mk <$> runHtmlT m <*> runHtmlT n+    where mk ~(g, _) ~(h, b) = (g <> h, b)   {-# INLINE (*>) #-} -  m <* n = HtmlT $ do-    ~(g, a) <- runHtmlT m-    ~(h, _) <- runHtmlT n-    return (g <> h, a)+  m <* n = HtmlT $ mk <$> runHtmlT m <*> runHtmlT n+    where mk ~(g, a) ~(h, _) = (g <> h, a)   {-# INLINE (<*) #-}  -- | Just re-uses Monad.-instance Monad m => Functor (HtmlT m) where-  fmap = liftM+instance Functor m => Functor (HtmlT m) where+  fmap f = HtmlT . fmap (fmap f) . runHtmlT    (<$) = fmap . const   {-# INLINE (<$) #-}  -- | Basically acts like Writer. instance Monad m => Monad (HtmlT m) where-  return = pure+  return a = HtmlT (return (mempty,a))   {-# INLINE return #-}    m >>= f = HtmlT $ do@@ -155,7 +149,10 @@     return (g <> h,b)   {-# INLINE (>>=) #-} -  (>>) = (*>)+  m >> n = HtmlT $ do+    ~(g, _) <- runHtmlT m+    ~(h, b) <- runHtmlT n+    return (g <> h, b)   {-# INLINE (>>) #-}  -- | Used for 'lift'.@@ -186,9 +183,9 @@ -- | @since 2.9.9 instance MonadWriter w m => MonadWriter w (HtmlT m) where     tell             = lift . tell-    listen (HtmlT x) = HtmlT $ liftM reassoc $ listen x+    listen (HtmlT x) = HtmlT $ fmap reassoc $ listen x       where reassoc ((a, b), c) = (a, (b, c))-    pass (HtmlT p)   = HtmlT $ pass $ liftM assoc p+    pass (HtmlT p)   = HtmlT $ pass $ fmap assoc p       where assoc (a, (b, c)) = ((a, b), c)  -- | If you want to use IO in your HTML generation.@@ -285,12 +282,12 @@            -> result        -- ^ Result: either an element or an attribute.  -- | Given attributes, expect more child input.-instance (Monad m,f ~ HtmlT m a) => Term [Attribute] (f -> HtmlT m a) where+instance (Applicative m,f ~ HtmlT m a) => Term [Attribute] (f -> HtmlT m a) where   termWith name f = with (makeElement name) . (<> f)  -- | Given children immediately, just use that and expect no -- attributes.-instance (Monad m) => Term (HtmlT m a) (HtmlT m a) where+instance (Applicative m) => Term (HtmlT m a) (HtmlT m a) where   termWith name f = with (makeElement name) f   {-# INLINE termWith #-} @@ -339,24 +336,20 @@        -> a  -- | For the contentless elements: 'Lucid.Html5.br_'-instance (Monad m) => With (HtmlT m a) where-  with f =-    \attr ->-      HtmlT (do ~(f',a) <- runHtmlT f-                return (\attr' ->-                          f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr')-                       ,a))-    where toPair (Attribute x y) = (x,y)+instance (Functor m) => With (HtmlT m a) where+  with f = \attr -> HtmlT (mk attr <$> runHtmlT f)+    where +      mk attr ~(f',a) = (\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr')+                        ,a)+      toPair (Attribute x y) = (x,y)  -- | For the contentful elements: 'Lucid.Html5.div_'-instance (Monad m) => With (HtmlT m a -> HtmlT m a) where-  with f =-    \attr inner ->-      HtmlT (do ~(f',a) <- runHtmlT (f inner)-                return ((\attr'  ->-                           f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr') )-                       ,a))-    where toPair (Attribute x y) = (x,y)+instance (Functor m) => With (HtmlT m a -> HtmlT m a) where+  with f = \attr inner -> HtmlT (mk attr <$> runHtmlT (f inner))+    where+      mk attr ~(f',a) = (\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr')+                        ,a)+      toPair (Attribute x y) = (x,y)  -- | Union two sets of arguments and append duplicate keys. unionArgs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text@@ -400,7 +393,7 @@ -- the lower-level behaviour. -- renderBST :: Monad m => HtmlT m a -> m ByteString-renderBST = liftM Blaze.toLazyByteString . execHtmlT+renderBST = fmap Blaze.toLazyByteString . execHtmlT  -- | Render the HTML to a lazy 'Text', but in a monad. --@@ -409,7 +402,7 @@ -- you're interested in the lower-level behaviour. -- renderTextT :: Monad m => HtmlT m a -> m LT.Text-renderTextT = liftM (LT.decodeUtf8 . Blaze.toLazyByteString) . execHtmlT+renderTextT = fmap (LT.decodeUtf8 . Blaze.toLazyByteString) . execHtmlT  -------------------------------------------------------------------------------- -- Running, transformer versions@@ -490,36 +483,37 @@ makeAttribute x y = Attribute x y  -- | Make an HTML builder.-makeElement :: Monad m+makeElement :: Functor m             => Text       -- ^ Name.             -> HtmlT m a  -- ^ Children HTML.             -> HtmlT m a -- ^ A parent element. {-# INLINE[1] makeElement #-}-makeElement name =-  \m' ->-    HtmlT (do ~(f,a) <- runHtmlT m'-              return (\attr  -> s "<" <> Blaze.fromText name-                              <> foldlMapWithKey buildAttr attr <> s ">"-                              <> f mempty-                              <> s "</" <> Blaze.fromText name <> s ">",-                      a))+makeElement name = \m' -> HtmlT (mk <$> runHtmlT m')+  where+    mk ~(f,a) =+      (\attr ->+        s "<" <> Blaze.fromText name+        <> foldlMapWithKey buildAttr attr <> s ">"+        <> f mempty+        <> s "</" <> Blaze.fromText name <> s ">"+      ,a)  -- | Make an HTML builder for elements which have no ending tag.-makeElementNoEnd :: Monad m+makeElementNoEnd :: Applicative m                  => Text       -- ^ Name.                  -> HtmlT m () -- ^ A parent element. makeElementNoEnd name =-  HtmlT (return (\attr -> s "<" <> Blaze.fromText name-                          <> foldlMapWithKey buildAttr attr <> s ">",+  HtmlT (pure (\attr -> s "<" <> Blaze.fromText name+                        <> foldlMapWithKey buildAttr attr <> s ">",                  ()))  -- | Make an XML builder for elements which have no ending tag.-makeXmlElementNoEnd :: Monad m+makeXmlElementNoEnd :: Applicative m                     => Text       -- ^ Name.                     -> HtmlT m () -- ^ A parent element. makeXmlElementNoEnd name =-  HtmlT (return (\attr -> s "<" <> Blaze.fromText name-                          <> foldlMapWithKey buildAttr attr <> s "/>",+  HtmlT (pure (\attr -> s "<" <> Blaze.fromText name+                        <> foldlMapWithKey buildAttr attr <> s "/>",                  ()))  -- | Build and encode an attribute.
src/Lucid/Html5.hs view
@@ -15,14 +15,12 @@ -- Elements  -- | @DOCTYPE@ element-doctype_ :: Monad m => HtmlT m ()+doctype_ :: Applicative m => HtmlT m () doctype_ = makeElementNoEnd "!DOCTYPE HTML"  -- | @DOCTYPE@ element + @html@ element-doctypehtml_ :: Monad m => HtmlT m a -> HtmlT m a-doctypehtml_ m =-  do doctype_-     html_ m+doctypehtml_ :: Applicative m => HtmlT m a -> HtmlT m a+doctypehtml_ m = doctype_ *> html_ m  -- | @a@ element a_ :: Term arg result => arg -> result@@ -37,7 +35,7 @@ address_ = term "address"  -- | @area@ element-area_ :: Monad m => [Attribute] -> HtmlT m ()+area_ :: Applicative m => [Attribute] -> HtmlT m () area_ = with (makeElementNoEnd "area")  -- | @article@ element@@ -57,7 +55,7 @@ b_ = term "b"  -- | @base@ element-base_ :: Monad m => [Attribute] -> HtmlT m ()+base_ :: Applicative m => [Attribute] -> HtmlT m () base_ = with (makeElementNoEnd "base")  -- | @bdo@ element@@ -73,7 +71,7 @@ body_ = term "body"  -- | @br@ element-br_ :: Monad m => [Attribute] -> HtmlT m ()+br_ :: Applicative m => [Attribute] -> HtmlT m () br_ = with (makeElementNoEnd "br")  -- | @button@ element@@ -97,7 +95,7 @@ code_ = term "code"  -- | @col@ element-col_ :: Monad m => [Attribute] -> HtmlT m ()+col_ :: Applicative m => [Attribute] -> HtmlT m () col_ = with (makeElementNoEnd "col")  -- | @colgroup@ element@@ -145,7 +143,7 @@ em_ = term "em"  -- | @embed@ element-embed_ :: Monad m => [Attribute] -> HtmlT m ()+embed_ :: Applicative m => [Attribute] -> HtmlT m () embed_ = with (makeElementNoEnd "embed")  -- | @fieldset@ element@@ -205,7 +203,7 @@ hgroup_ = term "hgroup"  -- | @hr@ element-hr_ :: Monad m => [Attribute] -> HtmlT m ()+hr_ :: Applicative m => [Attribute] -> HtmlT m () hr_ = with (makeElementNoEnd "hr")  -- | @html@ element@@ -221,11 +219,11 @@ iframe_ = term "iframe"  -- | @img@ element-img_ :: Monad m => [Attribute] -> HtmlT m ()+img_ :: Applicative m => [Attribute] -> HtmlT m () img_ = with (makeElementNoEnd "img")  -- | @input@ element-input_ :: Monad m => [Attribute] -> HtmlT m ()+input_ :: Applicative m => [Attribute] -> HtmlT m () input_ = with (makeElementNoEnd "input")  -- | @ins@ element@@ -237,7 +235,7 @@ kbd_ = term "kbd"  -- | @keygen@ element-keygen_ :: Monad m => [Attribute] -> HtmlT m ()+keygen_ :: Applicative m => [Attribute] -> HtmlT m () keygen_ = with (makeElementNoEnd "keygen")  -- | @label@ element or @label@ attribute@@ -253,7 +251,7 @@ li_ = term "li"  -- | @link@ element-link_ :: Monad m => [Attribute] -> HtmlT m ()+link_ :: Applicative m => [Attribute] -> HtmlT m () link_ = with (makeElementNoEnd "link")  -- | @map@ element@@ -273,11 +271,11 @@ menu_ = term "menu"  -- | @menuitem@ element-menuitem_ :: Monad m => [Attribute] -> HtmlT m ()+menuitem_ :: Applicative m => [Attribute] -> HtmlT m () menuitem_ = with (makeElementNoEnd "menuitem")  -- | @meta@ element-meta_ :: Monad m => [Attribute] -> HtmlT m ()+meta_ :: Applicative m => [Attribute] -> HtmlT m () meta_ = with (makeElementNoEnd "meta")  -- | @meter@ element@@ -317,7 +315,7 @@ p_ = term "p"  -- | @param@ element-param_ :: Monad m => [Attribute] -> HtmlT m ()+param_ :: Applicative m => [Attribute] -> HtmlT m () param_ = with (makeElementNoEnd "param")  -- | The @svg@ attribute.@@ -369,7 +367,7 @@ small_ = term "small"  -- | @source@ element-source_ :: Monad m => [Attribute] -> HtmlT m ()+source_ :: Applicative m => [Attribute] -> HtmlT m () source_ = with (makeElementNoEnd "source")  -- | @span@ element or @span@ attribute@@ -441,7 +439,7 @@ tr_ = term "tr"  -- | @track@ element-track_ :: Monad m => [Attribute] -> HtmlT m ()+track_ :: Applicative m => [Attribute] -> HtmlT m () track_ = with (makeElementNoEnd "track")  -- | @ul@ element@@ -457,7 +455,7 @@ video_ = term "video"  -- | @wbr@ element-wbr_ :: Monad m => [Attribute] -> HtmlT m ()+wbr_ :: Applicative m => [Attribute] -> HtmlT m () wbr_ = with (makeElementNoEnd "wbr")  -------------------------------------------------------------------------------
test/Main.hs view
@@ -10,6 +10,7 @@ import Lucid.Base import Lucid.Bootstrap +import Control.Applicative import Control.Monad.State.Strict  import Example1@@ -206,7 +207,7 @@   where     example = renderText $ evalState (commuteHtmlT exampleHtml) 1 -    exampleHtml :: MonadState Int m => HtmlT m ()+    exampleHtml :: (Applicative m, MonadState Int m) => HtmlT m ()     exampleHtml = ul_ $ replicateM_ 5 $ do       x <- get       put (x + 1)