Fix GNUmakefile.
[doclang.git] / Text / Blaze / Utils.hs
index a3e0fa2a54ad38298e4699926bdbfb34d9bef450..1cb5e30a73cbb93ba4575634d2629ca961e99313 100644 (file)
 {-# 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
@@ -68,7 +130,7 @@ prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
        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 ->