{-# language OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Text.Blaze.Utils where import Blaze.ByteString.Builder (Builder) import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) 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 GHC.Exts (IsList(..)) import Prelude (Num(..), undefined) import System.IO (IO) import Text.Blaze as B import Text.Blaze.Internal as B hiding (null) import Text.Show (Show(..)) import qualified Blaze.ByteString.Builder as BS import qualified Blaze.ByteString.Builder.Html.Utf8 as BS 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.Encoding as BS import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Renderer.Utf8 as BS import Control.Monad.Utils -- | 'Attribute' in 'Maybe'. infixl 1 !?? (!??) :: 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 -} instance IsList H.AttributeValue where type Item AttributeValue = AttributeValue fromList = mconcat . List.intersperse " " toList = pure -- * Class 'Attrify' class Attrify a where attrify :: a -> H.AttributeValue instance Attrify Char where attrify = fromString . pure instance Attrify Text where attrify = fromString . Text.unpack instance Attrify TL.Text where attrify = fromString . TL.unpack instance Attrify Int where attrify = fromString . show instance Attrify [Char] where attrify = 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 TL.Text where mayAttr _ "" = Nothing mayAttr a t = Just (a $ fromString $ TL.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) instance MayAttr AttributeValue where mayAttr a = Just . a -- * Type 'ComposeState' instance Semigroup (ComposeState st B.MarkupM a) where (<>) = (>>) instance Monoid (ComposeState st B.MarkupM ()) where mempty = pure () mappend = (<>) instance Monad (ComposeState st B.MarkupM) 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 -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'. -- | Render some 'Markup' to a 'Builder'. -- -- An 'IndentTag' is queried on each tag -- to indent tags differently according to their names. prettyMarkupBuilder :: (Text -> Bool) -> Markup -> Builder prettyMarkupBuilder isInlinedElement ms = go (noIndent "" ms) "\n" mempty ms where inc :: Builder inc = " " noIndent :: Text -> MarkupM b -> Bool noIndent e children = isInlinedElement e || allInlined children && not (allComment children) where allInlined :: MarkupM b -> Bool allInlined = \case Append x y -> allInlined x && allInlined y CustomParent tag _m -> isInlinedElement $ t_ChoiceString tag CustomLeaf tag _close _ -> isInlinedElement $ t_ChoiceString tag Parent tag _open _close _m -> isInlinedElement $ getText tag Leaf tag _begin _end _ -> isInlinedElement $ getText tag AddAttribute _ _key _value m -> allInlined m AddCustomAttribute _key _value m -> allInlined m Comment{} -> True Content{} -> True Empty{} -> True allComment :: MarkupM b -> Bool allComment = \case Append x y -> allComment x && allComment y AddAttribute _ _key _value m -> allComment m AddCustomAttribute _key _value m -> allComment m Comment{} -> True Empty{} -> True _ -> False goAttrs :: Bool -> Builder -> Text -> [Builder] -> Builder goAttrs noInd ind t_tag attrs = case attrs of [] -> mempty [a] -> a a0:as -> let ind_key = BS.fromString $ List.replicate (Text.length t_tag + 1) ' ' in let ind_attr = if noInd then mempty else ind<>ind_key in a0 <> foldMap (ind_attr <>) as go :: Bool -> Builder -> [Builder] -> MarkupM b -> Builder go noInd ind attrs = \case Parent tag open close content -> let noInd' = noIndent (getText tag) content in (if noInd then mempty else ind) <> BS.copyByteString (getUtf8ByteString open) <> goAttrs noInd ind (getText tag) attrs <> BS.fromChar '>' <> go noInd' (if noInd then ind else ind<>inc) mempty content <> (if noInd' then mempty else ind) <> BS.copyByteString (getUtf8ByteString close) CustomParent tag content -> let t_tag = t_ChoiceString tag in let noInd' = noIndent t_tag content in (if noInd then mempty else ind) <> BS.fromChar '<' <> BS.fromText t_tag <> goAttrs noInd ind t_tag attrs <> BS.fromChar '>' <> go noInd' (if noInd' then ind else ind<>inc) mempty content <> (if noInd' then mempty else ind) <> BS.fromByteString " bs_ChoiceString tag <> BS.fromChar '>' Leaf tag begin end _ -> (if noInd then mempty else ind) <> BS.copyByteString (getUtf8ByteString begin) <> goAttrs noInd ind (getText tag) attrs <> BS.copyByteString (getUtf8ByteString end) CustomLeaf tag close _ -> let t_tag = t_ChoiceString tag in (if noInd then mempty else ind) <> BS.fromChar '<' <> BS.fromText t_tag <> goAttrs noInd ind t_tag attrs <> (if close then BS.fromByteString "/>" else BS.fromChar '>') AddAttribute _ key value m -> go noInd ind ( BS.copyByteString (getUtf8ByteString key) <> bs_ChoiceString value <> BS.fromChar '"' : attrs ) m AddCustomAttribute key value m -> go noInd ind ( BS.fromChar ' ' <> bs_ChoiceString key <> BS.fromByteString "=\"" <> bs_ChoiceString value <> BS.fromChar '"' : attrs ) m Content c _ -> bs_ChoiceString c Comment comment _ -> (if noInd then mempty else ind) <> BS.fromByteString "" Append m1 m2 -> go noInd ind attrs m1 <> go noInd ind attrs m2 Empty _ -> mempty -- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'. prettyMarkup :: (Text -> Bool) -> Markup -> BSL.ByteString prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind prettyMarkupIO :: (Text -> Bool) -> (BS.ByteString -> IO ()) -> Markup -> IO () prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind bs_ChoiceString :: ChoiceString -> Builder bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ()) t_ChoiceString :: ChoiceString -> Text t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString -- | @indentText ind txt@ indent 'txt' with 'ind' at newlines. indentText :: Builder -> Text -> Builder indentText ind = mconcat . List.intersperse ind . (BS.fromHtmlEscapedText <$>) . Text.splitOn "\n" -- | Render an indented 'ChoiceString'. indentChoiceString :: Builder -> ChoiceString -> Builder indentChoiceString ind (Static s) = indentText ind $ getText s indentChoiceString ind (String s) = indentText ind $ Text.pack s indentChoiceString ind (Text s) = indentText ind s indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s indentChoiceString ind (PreEscaped x) = case x of String s -> indentText ind $ Text.pack s Text s -> indentText ind s s -> indentChoiceString ind s indentChoiceString ind (External x) = case x of -- Check that the sequence " if " if " if " indentChoiceString ind s indentChoiceString ind (AppendChoiceString x y) = indentChoiceString ind x <> indentChoiceString ind y indentChoiceString ind EmptyChoiceString = indentText ind mempty {-# INLINE indentChoiceString #-}