{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Utils where
--- import Data.Ord (Ord(..))
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 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
--- * 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
inc :: Builder
inc = " "
bs_Attrs i ind t_tag attrs =
- case List.reverse attrs of
+ case {-List.reverse-} attrs of
[] -> mempty
[a] -> a
a0:as ->