module Text.Hamlet.Monad
(
Iteratee
, Enumerator (..)
, fromList
, Hamlet (..)
, HtmlContent (..)
, output
, outputHtml
, outputString
, outputUrl
, outputUrlParams
, outputEmbed
, showUrl
, liftHamlet
, mapH
, condH
, maybeH
, printHamlet
, hamletToText
, cdata
) where
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as L
import qualified Data.Text.IO as T
import Control.Applicative
import Control.Monad
import Web.Encodings
import Data.Monoid
import Data.List
type Iteratee val seed m = seed -> val -> m (Either seed seed)
newtype Enumerator val m = Enumerator
{ runEnumerator :: forall seed.
Iteratee val seed m -> seed
-> m (Either seed seed)
}
fromList :: Monad m => [a] -> Enumerator a m
fromList x = Enumerator $ go x where
go [] _ seed = return $ Right seed
go (l:ls) iter seed = do
ea <- iter seed l
case ea of
Left seed' -> return $ Left seed'
Right seed' -> go ls iter seed'
newtype Hamlet url m a = Hamlet
{ runHamlet :: forall seed.
(url -> String)
-> seed
-> Iteratee Text seed m
-> m (Either seed (a, seed))
}
instance Monad m => Monad (Hamlet url m) where
return x = Hamlet $ \_ seed _ -> return (Right (x, seed))
(Hamlet f) >>= g = Hamlet go where
go a c d = f a c d >>= go' a d
go' _ _ (Left seed) = return $ Left seed
go' a d (Right (v, seed)) = runHamlet (g v) a seed d
instance Monad m => Functor (Hamlet url m) where
fmap = liftM
instance Monad m => Applicative (Hamlet url m) where
pure = return
(<*>) = ap
output :: Monad m => Text -> Hamlet url m ()
output bs = Hamlet go where
go _ seed iter = do
ea <- iter seed bs
case ea of
Left seed' -> return $ Left seed'
Right seed' -> return $ Right ((), seed')
data HtmlContent = Encoded Text | Unencoded Text
deriving (Eq, Show, Read)
instance Monoid HtmlContent where
mempty = Encoded mempty
mappend (Encoded x) (Encoded y) = Encoded $ mappend x y
mappend (Unencoded x) (Unencoded y) = Unencoded $ mappend x y
mappend (Encoded x) (Unencoded y) = Encoded $ mappend x
$ encodeHtml y
mappend (Unencoded x) (Encoded y) = Encoded $ mappend
(encodeHtml x) y
cdata :: HtmlContent -> HtmlContent
cdata h = mconcat
[ Encoded $ pack "<![CDATA["
, h
, Encoded $ pack "]]>"
]
outputHtml :: Monad m => HtmlContent -> Hamlet url m ()
outputHtml (Encoded t) = output t
outputHtml (Unencoded t) = output $ encodeHtml t
outputString :: Monad m => String -> Hamlet url m ()
outputString = output . pack
outputUrl :: Monad m => url -> Hamlet url m ()
outputUrl u = showUrl u >>= outputString
outputUrlParams :: Monad m => (url, [(String, String)]) -> Hamlet url m ()
outputUrlParams (u, params) = do
outputUrl u
outputString $ showParams params
where
showParams x = '?' : intercalate "&" (map go x)
go (x, y) = go' x ++ '=' : go' y
go' = concatMap encodeUrlChar
encodeUrlChar :: Char -> String
encodeUrlChar c
| 'A' <= c && c <= 'Z' = [c]
| 'a' <= c && c <= 'z' = [c]
| '0' <= c && c <= '9' = [c]
encodeUrlChar c@'-' = [c]
encodeUrlChar c@'_' = [c]
encodeUrlChar c@'.' = [c]
encodeUrlChar c@'~' = [c]
encodeUrlChar ' ' = "+"
encodeUrlChar y =
let (a, c) = fromEnum y `divMod` 16
b = a `mod` 16
showHex' x
| x < 10 = toEnum $ x + (fromEnum '0')
| x < 16 = toEnum $ x 10 + (fromEnum 'A')
| otherwise = error $ "Invalid argument to showHex: " ++ show x
in ['%', showHex' b, showHex' c]
outputEmbed :: Monad m => Hamlet url m () -> Hamlet url m ()
outputEmbed = id
showUrl :: Monad m => url -> Hamlet url m String
showUrl url = Hamlet $ \s seed _ -> return (Right (s url, seed))
liftHamlet :: Monad m => m a -> Hamlet url m a
liftHamlet m = Hamlet $ \_ c _ -> m >>= \m' -> return (Right (m', c))
mapH :: Monad m
=> (val -> Hamlet url m ())
-> Enumerator val m
-> Hamlet url m ()
mapH each (Enumerator e) = Hamlet go where
go surl seed iter = do
res <- e (iter' surl iter) seed
case res of
Left seed' -> return $ Left seed'
Right seed' -> return $ Right ((), seed')
iter' surl iter seed val = do
res <- runHamlet (each val) surl seed iter
case res of
Left seed' -> return $ Left seed'
Right ((), seed') -> return $ Right seed'
condH :: Monad m
=> [(m Bool, Hamlet url m ())]
-> Maybe (Hamlet url m ())
-> Hamlet url m ()
condH [] Nothing = return ()
condH [] (Just x) = x
condH ((x, y):rest) z = do
x' <- liftHamlet x
if x' then y else condH rest z
maybeH :: Monad m
=> Maybe v
-> (v -> Hamlet url m ())
-> Hamlet url m ()
maybeH Nothing _ = return ()
maybeH (Just v) f = f v
printHamlet :: (url -> String) -> Hamlet url IO () -> IO ()
printHamlet render h = runHamlet h render () iter >> return () where
iter () text = do
T.putStr text
return $ Right ()
hamletToText :: Monad m => (url -> String) -> Hamlet url m () -> m L.Text
hamletToText render h = do
Right ((), front) <- runHamlet h render id iter
return $ L.fromChunks $ front []
where
iter front text = return $ Right $ front . (:) text