nice-html 0.1.2 → 0.2.0
raw patch · 5 files changed
+87/−58 lines, 5 files
Files
- nice-html.cabal +1/−1
- src/Text/Html/Nice.hs +5/−3
- src/Text/Html/Nice/FreeMonad.hs +1/−1
- src/Text/Html/Nice/Internal.hs +57/−44
- src/Text/Html/Nice/Writer.hs +23/−9
nice-html.cabal view
@@ -1,5 +1,5 @@ name: nice-html-version: 0.1.2+version: 0.2.0 category: Web description: A fast and nice HTML templating library with distinct compilation/rendering phases. synopsis: A fast and nice HTML templating library with distinct compilation/rendering phases.
src/Text/Html/Nice.hs view
@@ -2,6 +2,7 @@ ( -- * Nice HTML writer monad module Text.Html.Nice.Writer+ , Attr (..) -- * HTML5 support , module Text.Html.Nice.Writer.Html5 -- * Rendering@@ -26,8 +27,9 @@ import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder.Int import Data.Text.Lazy.Builder.RealFloat-import Text.Html.Nice.Internal ((:$) (..), FastMarkup,- Render (..), recompile,- render, renderM, renderMs)+import Text.Html.Nice.Internal ((:$) (..), Attr (..),+ FastMarkup, Render (..),+ recompile, render, renderM,+ renderMs) import Text.Html.Nice.Writer import Text.Html.Nice.Writer.Html5
src/Text/Html/Nice/FreeMonad.hs view
@@ -237,7 +237,7 @@ -> Markup (f a -> FastMarkup n) r stream m = embed $ \fa -> case F.toList fa of [] -> FEmpty- list -> FStream (ListS list (\a -> fmap ($ a) fm))+ list -> FStream (ListS list fm) where !fm = compile m
src/Text/Html/Nice/Internal.hs view
@@ -17,9 +17,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Text.Html.Nice.Internal where import Control.DeepSeq (NFData (..)) import Control.Monad+import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.State.Strict (evalState, get, modify') import Data.Bifunctor.TH import Data.Functor.Foldable.TH@@ -29,6 +31,8 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Builder.Int as TLB+import qualified Data.Text.Lazy.Builder.RealFloat as TLB import Data.Vector (Vector) import qualified Data.Vector as V import Data.Void@@ -69,58 +73,42 @@ deriving (Show, Eq, Functor, Foldable, Traversable) data Stream a- = forall s. ListS [s] (s -> FastMarkup a)- | forall s t. S !s !(s -> Next s t) !(t -> FastMarkup a)+ = forall s. ListS [s] (FastMarkup (s -> a))+ | S [FastMarkup a] instance Show a => Show (Stream a) where- show (ListS s f) = "(Stream (" ++ show (map f s) ++ "))"- show (S s next f) = show (ListS (asList s) f)- where- asList s1 = case next s1 of- Next s2 a -> a : asList s2- Done a -> [a]+ show (ListS s f) = "(Stream (" ++ show (map (\a -> fmap ($ a) f) s) ++ "))"+ show (S fm) = "(S " ++ show fm ++ ")" -- | Don't use this! It's a lie! instance Eq (Stream a) where _ == _ = True instance Functor Stream where- fmap f (S s next fm) = S s next (\s' -> fmap f (fm s'))- fmap f (ListS l g) = ListS l (\s -> fmap f (g s))+ fmap f (ListS l g) = ListS l (fmap (fmap f) g)+ fmap f (S x) = S (fmap (fmap f) x) instance Foldable Stream where- foldMap f (S s0 next fm) = go s0- where- go s = case next s of- Next s1 a -> foldMap f (fm a) <> go s1- Done a -> foldMap f (fm a)- foldMap f (ListS s fm) = foldMap (foldMap f . fm) s+ foldMap f s = unstream (foldMap f) s mappend mempty -instance NFData (Stream a) where- rnf (S !_ !_ !_) = ()- rnf (ListS !_ !_) = ()+instance NFData a => NFData (Stream a) where+ rnf (ListS !_ !s) = rnf s+ rnf (S fm) = rnf fm +{-# INLINE unstream #-} unstream :: (FastMarkup a -> b) -> Stream a -> (b -> c -> c) -> c -> c unstream f (ListS l fm) cons nil = go l where- go (x:xs) = cons (f (fm x)) (go xs)+ go (x:xs) = cons (f (fmap ($ x) fm)) (go xs) go [] = nil-unstream f (S s0 next fm) cons nil = go s0+unstream f (S l) cons nil = go l where- go s = case next s of- Next s1 a -> cons (f (fm a)) (go s1)- Done a -> cons (f (fm a)) nil+ go (x:xs) = cons (f x) (go xs)+ go [] = nil instance Traversable Stream where -- phew ...- traverse f str =- (\s0' -> ListS s0' id) <$>- sequenceA (unstream (traverse f) str (:) [])--data Next s a- = Next !s !a- | Done !a- deriving (Show, Eq, Functor, Foldable, Traversable)+ traverse f str = S <$> sequenceA (unstream (traverse f) str (:) []) -------------------------------------------------------------------------------- -- Compiling@@ -332,24 +320,13 @@ renderM f = go where - runStream (S s0 next fm) = rgo s0- where- rgo s' = case next s' of- Next xs x -> mappend <$> go (fm x) <*> rgo xs- Done x -> go (fm x)-- runStream (ListS l fm) = rgo l- where- rgo (x:xs) = mappend <$> go (fm x) <*> rgo xs- rgo _ = pure mempty- go fm = case fm of Bunch v -> V.foldM (\a b -> return (a <> b)) mempty =<< V.mapM go v FBuilder t -> return t FSText t -> return (TLB.fromText t) FLText t -> return (TLB.fromLazyText t) FHole _ a -> f a- FStream str -> runStream str+ FStream str -> unstream go str (liftM2 mappend) (return mempty) _ -> return mempty {-# INLINE renderMs #-}@@ -365,6 +342,11 @@ class Render a m where r :: a -> m TLB.Builder +-- needs undecidableinstances ...+instance (Render b m, m' ~ ReaderT a m) => Render (a -> b) m' where+ {-# INLINE r #-}+ r f = ReaderT (\a -> r (f a))+ -- | Defer application of an argument to rendering instance (Monad m, Render b m) => Render (a :$ b) m where {-# INLINE r #-}@@ -382,3 +364,34 @@ {-# INLINE r #-} r = renderM r +--------------------------------------------------------------------------------++class ToFastMarkup a where+ toFastMarkup :: a -> FastMarkup b++instance ToFastMarkup Text where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = FSText++instance ToFastMarkup TL.Text where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = FLText++instance ToFastMarkup TLB.Builder where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = FBuilder++newtype AsDecimal a = AsDecimal { asDecimal :: a }+instance Integral a => ToFastMarkup (AsDecimal a) where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = toFastMarkup . TLB.decimal . asDecimal++newtype AsHex a = AsHex { asHex :: a }+instance Integral a => ToFastMarkup (AsHex a) where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = toFastMarkup . TLB.hexadecimal . asHex++newtype AsRealFloat a = AsRealFloat { asRealFloat :: a }+instance RealFloat a => ToFastMarkup (AsRealFloat a) where+ {-# INLINE toFastMarkup #-}+ toFastMarkup = toFastMarkup . TLB.realFloat . asRealFloat
src/Text/Html/Nice/Writer.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-}@@ -28,9 +29,11 @@ , builderRaw , stringRaw -- * Combinators+ , AddAttr , (!) , dynamic , dynamicRaw+ , using , sub -- ** Streaming , stream@@ -130,6 +133,9 @@ -------------------------------------------------------------------------------- -- Node types +using :: ToFastMarkup b => (a -> b) -> Markup (a -> FastMarkup r) ()+using f = dynamic (toFastMarkup . f)+ {-# INLINE dynamic #-} dynamic :: p -> Markup p () dynamic = lift . Hole DoEscape@@ -144,13 +150,23 @@ -------------------------------------------------------------------------------- -- Combinators -{-# INLINE (!) #-}--- | Add some attributes-(!) :: (Markup t a -> Markup t b) -> [Attr t] -> Markup t a -> Markup t b-(!) f a x = Markup $ \i attrs ->- case f x of- Markup m -> m i (a ++ attrs)+type MarkupLike a = a +class AddAttr a t | a -> t where+ addAttr :: a -> Attr t -> a++instance AddAttr (Markup t a -> Markup t b) t where+ addAttr f a x = Markup $ \i attrs ->+ case f x of+ Markup m -> m i (a:attrs)++instance AddAttr (Markup t a) t where+ addAttr f a = Markup $ \i attrs ->+ case f of+ Markup m -> m i (a:attrs)++(!) :: AddAttr a t => MarkupLike a -> Attr t -> MarkupLike a+(!) = addAttr infixl 8 ! {-# INLINE stream #-}@@ -158,9 +174,7 @@ => Markup (a -> n) r -> Markup (f a -> FastMarkup n) r stream m =- result <$ dynamic (\fa -> FStream (ListS- (toList fa)- (\a -> fmap ($ a) fm)))+ result <$ dynamic (\fa -> FStream (ListS (toList fa) fm)) where (result, !fm) = runMarkup m