{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Utils where
import Blaze.ByteString.Builder (Builder)
-import Control.Monad (return)
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..))
import Data.Bool
+import Data.Char (Char)
import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
import Data.Function ((.), ($))
import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
+import Prelude (Num(..), undefined)
import System.IO (IO)
import Text.Blaze as B
-import Text.Blaze.Internal as B
+import Text.Blaze.Internal as B hiding (null)
import Text.Show (Show(..))
-import qualified Data.List as List
import qualified Blaze.ByteString.Builder as BS
import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
+import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
+import qualified Data.List as List
import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Encoding as BS
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Renderer.Utf8 as BS
-import qualified Data.Text.Encoding as BS
-- | 'Attribute' in 'Maybe'.
infixl 1 !??
-(!??) :: Attributable h => h -> (Maybe a, a -> Attribute) -> h
-(!??) h (m,a) = maybe h (\x -> h ! a x) m
+(!??) :: Attributable h => h -> Maybe Attribute -> h
+(!??) h = maybe h (h !)
whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
whenMarkup Empty{} _b = return ()
whenMarkup _a b = b
+whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+whenJust Nothing _f = pure ()
+whenJust (Just a) f = f a
+
+whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
+whenSome x _f | null x = pure ()
+whenSome x f = f x
+
+whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
+whenText "" _f = pure ()
+whenText t f = f t
+
instance Semigroup H.AttributeValue where
(<>) = mappend
--- * Class 'Attributable'
+-- * Class 'AttrValue'
class AttrValue a where
attrValue :: a -> H.AttributeValue
+instance AttrValue Char where
+ attrValue = fromString . pure
instance AttrValue Text where
attrValue = fromString . Text.unpack
+instance AttrValue TL.Text where
+ attrValue = fromString . TL.unpack
instance AttrValue Int where
attrValue = fromString . show
+instance AttrValue [Char] where
+ attrValue = fromString
+
+-- * Class 'MayAttr'
+class MayAttr a where
+ mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
+instance MayAttr a => MayAttr (Maybe a) where
+ mayAttr a t = t >>= mayAttr a
+instance MayAttr Text where
+ mayAttr _ "" = Nothing
+ mayAttr a t = Just (a $ fromString $ Text.unpack t)
+instance MayAttr Int where
+ mayAttr a t = Just (a $ fromString $ show t)
+instance MayAttr [Char] where
+ mayAttr _ "" = Nothing
+ mayAttr a t = Just (a $ fromString t)
+
+-- * Type 'StateMarkup'
+-- | Composing state and markups.
+type StateMarkup st = Compose (S.State st) B.MarkupM
+instance Monad (StateMarkup st) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ case ma >>= B.Empty . a2csmb of
+ B.Append _ma (B.Empty csmb) ->
+ B.Append ma <$> getCompose csmb
+ _ -> undefined
+instance IsString (StateMarkup st ()) where
+ fromString = Compose . return . fromString
+
+-- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
+($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
+($$) f m = Compose $ f <$> getCompose m
+infixr 0 $$
+
+liftStateMarkup :: S.State st a -> StateMarkup st a
+liftStateMarkup = Compose . (return <$>)
+
+runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
+runStateMarkup st = (`S.runState` st) . getCompose
-- * Type 'IndentTag'
data IndentTag
where
inc :: Builder
inc = " "
- go :: IndentTag -> Builder -> Builder -> MarkupM b -> Builder
+ bs_Attrs i ind t_tag attrs =
+ case {-List.reverse-} attrs of
+ [] -> mempty
+ [a] -> a
+ a0:as ->
+ let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
+ let ind_attr =
+ case i of
+ IndentTagChildren -> ind<>ind_key
+ IndentTagPreserve -> mempty
+ IndentTagText -> mempty in
+ a0 <> foldMap (ind_attr <>) as
+ go :: IndentTag -> Builder -> [Builder] -> MarkupM b -> Builder
go i ind attrs (Parent tag open close content) =
let i' = indentTag (getText tag) in
(if i==IndentTagChildren then ind else mempty)
<> BS.copyByteString (getUtf8ByteString open)
- <> attrs
+ <> bs_Attrs i ind (getText tag) attrs
<> BS.fromChar '>'
<> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
<> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
<> BS.copyByteString (getUtf8ByteString close)
go i ind attrs (CustomParent tag content) =
let i' = indentTag (t_ChoiceString tag) in
+ let t_tag = t_ChoiceString tag in
(if i==IndentTagChildren then ind else mempty)
<> BS.fromChar '<'
- <> bs_ChoiceString tag
- <> attrs
+ <> BS.fromText t_tag
+ <> bs_Attrs i ind t_tag attrs
<> BS.fromChar '>'
<> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
<> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
<> BS.fromByteString "</"
<> bs_ChoiceString tag
<> BS.fromChar '>'
- go i ind attrs (Leaf _tag begin end _) =
+ go i ind attrs (Leaf tag begin end _) =
(if i==IndentTagChildren then ind else mempty)
<> BS.copyByteString (getUtf8ByteString begin)
- <> attrs
+ <> bs_Attrs i ind (getText tag) attrs
<> BS.copyByteString (getUtf8ByteString end)
go i ind attrs (CustomLeaf tag close _) =
+ let t_tag = t_ChoiceString tag in
(if i==IndentTagChildren then ind else mempty)
<> BS.fromChar '<'
- <> bs_ChoiceString tag
- <> attrs
- <> (if close then BS.fromByteString " />" else BS.fromChar '>')
+ <> BS.fromText t_tag
+ <> bs_Attrs i ind t_tag attrs
+ <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
go i ind attrs (AddAttribute _ key value m) =
- go i ind (BS.copyByteString (getUtf8ByteString key)
+ go i ind
+ ( BS.copyByteString (getUtf8ByteString key)
<> bs_ChoiceString value
<> BS.fromChar '"'
- <> attrs) m
+ : attrs ) m
go i ind attrs (AddCustomAttribute key value m) =
- go i ind (BS.fromChar ' '
+ go i ind
+ ( BS.fromChar ' '
<> bs_ChoiceString key
<> BS.fromByteString "=\""
<> bs_ChoiceString value
<> BS.fromChar '"'
- <> attrs) m
+ : attrs ) m
go i ind _attrs (Content content _) =
if i/=IndentTagPreserve
then indentChoiceString ind content
go i ind attrs (Append m1 m2) =
go i ind attrs m1 <>
go i ind attrs m2
- go _ip _ind _ (Empty _) = mempty
+ go _i _ind _attrs (Empty _) = mempty
{-# NOINLINE go #-}
-- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
sourcephile / git / doclang.git / blobdiff