{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Utils where
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.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
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 'AttrValue'
-class AttrValue a where
- attrValue :: a -> H.AttributeValue
-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 '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
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 '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 =
case ma >>= B.Empty . a2csmb of
B.Append _ma (B.Empty csmb) ->
B.Append ma <$> getCompose csmb
- _ -> undefined
+ _ -> 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
runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
runStateMarkup st = (`S.runState` st) . getCompose
-local :: Monad m => (s -> s) -> S.StateT s m b -> S.StateT s m b
-local f a = do
- s <- S.get
- S.put (f s)
- r <- a
- S.put s
- return r
-
--- * Type 'IndentTag'
-data IndentTag
- = IndentTagChildren
- | IndentTagText
- | IndentTagPreserve
- deriving (Eq,Show)
-
-- | 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