{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
{-# 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(..))
+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 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
-- | '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
+-}
+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
--- * Class 'Attributable'
-class AttrValue a where
- attrValue :: a -> H.AttributeValue
-instance AttrValue Text where
- attrValue = fromString . Text.unpack
-instance AttrValue Int where
- attrValue = fromString . show
-instance AttrValue [Char] where
- attrValue = fromString
-
--- * Type 'IndentTag'
-data IndentTag
- = IndentTagChildren
- | IndentTagText
- | IndentTagPreserve
- deriving (Eq,Show)
+-- * Type 'StateMarkup'
+-- | Composing state and markups.
+type StateMarkup st = Compose (S.State st) B.MarkupM
+instance Semigroup (StateMarkup st a) where
+ (<>) = (>>)
+instance Monoid (StateMarkup st ()) where
+ mempty = pure ()
+ mappend = (<>)
+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 -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.
+{- NOTE: the 'st' may need to use the 'String', so no such instance.
+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
-- | Render some 'Markup' to a 'Builder'.
--
-- An 'IndentTag' is queried on each tag
-- to indent tags differently according to their names.
-prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
-prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
+prettyMarkupBuilder :: (Text -> Bool) -> Markup -> Builder
+prettyMarkupBuilder isInlinedElement ms = go (noIndent "" ms) "\n" mempty ms
where
inc :: Builder
inc = " "
- bs_Attrs i ind t_tag attrs =
- case List.reverse attrs of
+ 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.fromText $ Text.replicate (Text.length t_tag + 1) " " in
- let ind_attr =
- case i of
- IndentTagChildren -> ind<>ind_key
- IndentTagPreserve -> mempty
- IndentTagText -> mempty in
+ 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 :: 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)
+ 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)
- <> bs_Attrs i ind (getText tag) attrs
+ <> goAttrs noInd 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
- <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
+ <> go noInd' (if noInd then ind else ind<>inc) mempty content
+ <> (if noInd' then mempty else ind)
<> 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)
+ 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
- <> bs_Attrs i ind t_tag attrs
+ <> goAttrs noInd 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
- <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
+ <> go noInd' (if noInd' then ind else ind<>inc) mempty content
+ <> (if noInd' then mempty else ind)
<> BS.fromByteString "</"
<> bs_ChoiceString tag
<> BS.fromChar '>'
- go i ind attrs (Leaf tag begin end _) =
- (if i==IndentTagChildren then ind else mempty)
+ Leaf tag begin end _ ->
+ (if noInd then mempty else ind)
<> BS.copyByteString (getUtf8ByteString begin)
- <> bs_Attrs i ind (getText tag) attrs
+ <> goAttrs noInd ind (getText tag) attrs
<> BS.copyByteString (getUtf8ByteString end)
- go i ind attrs (CustomLeaf tag close _) =
+ CustomLeaf tag close _ ->
let t_tag = t_ChoiceString tag in
- (if i==IndentTagChildren then ind else mempty)
+ (if noInd then mempty else ind)
<> BS.fromChar '<'
<> BS.fromText t_tag
- <> bs_Attrs i ind t_tag attrs
+ <> goAttrs noInd ind t_tag attrs
<> (if close then BS.fromByteString "/>" else BS.fromChar '>')
- go i ind attrs (AddAttribute _ key value m) =
- go i ind
+ AddAttribute _ key value m ->
+ go noInd ind
( BS.copyByteString (getUtf8ByteString key)
<> bs_ChoiceString value
<> BS.fromChar '"'
: attrs ) m
- go i ind attrs (AddCustomAttribute key value m) =
- go i ind
+ AddCustomAttribute key value m ->
+ go noInd ind
( BS.fromChar ' '
<> bs_ChoiceString key
<> BS.fromByteString "=\""
<> bs_ChoiceString value
<> BS.fromChar '"'
: attrs ) m
- go i ind _attrs (Content content _) =
- if i/=IndentTagPreserve
- then indentChoiceString ind content
- else bs_ChoiceString content
- go i ind _attrs (Comment comment _) =
- (if i==IndentTagChildren then ind else mempty)
+ Content c _ -> bs_ChoiceString c
+ Comment comment _ ->
+ (if noInd then mempty else ind)
<> BS.fromByteString "<!--"
- <> (if i==IndentTagChildren
- then indentChoiceString ind
- else bs_ChoiceString
- ) comment
+ <> indentChoiceString (ind <> " ") comment
+ <> (if noInd then mempty else ind)
<> BS.fromByteString "-->"
- go i ind attrs (Append m1 m2) =
- go i ind attrs m1 <>
- go i ind attrs m2
- go _i _ind _attrs (Empty _) = mempty
- {-# NOINLINE go #-}
+ 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 -> IndentTag) -> Markup -> BSL.ByteString
+prettyMarkup :: (Text -> Bool) -> Markup -> BSL.ByteString
prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind
-prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
+prettyMarkupIO :: (Text -> Bool) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind
bs_ChoiceString :: ChoiceString -> Builder
t_ChoiceString :: ChoiceString -> Text
t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString
--- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
+-- | @indentText ind txt@ indent 'txt' with 'ind' at newlines.
indentText :: Builder -> Text -> Builder
indentText ind =
mconcat .
sourcephile / git / doclang.git / blobdiff