module Text.Template.Inserts (
Template, runTemplate, parseTemplate, templateParser
) where
import Control.Applicative
import Control.Monad
import Data.Attoparsec.ByteString.Char8 ((.*>), (<*.))
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder as Sb
import qualified Data.ByteString.Lazy as Sl
import qualified Data.DList as Dl
import qualified Data.Foldable as F
import Data.Monoid
import Data.String
data TemplateC = Literal Sb.Builder | Hole S.ByteString
instance Show TemplateC where
show (Literal builder) =
"Literal " ++ show (Sl.toStrict (Sb.toLazyByteString builder))
show (Hole bs) = "Hole " ++ show bs
newtype Template =
Template { unTemplate :: Dl.DList TemplateC }
instance Monoid Template where
mempty = Template mempty
Template t1 `mappend` Template t2 = Template (mappend t1 t2)
data Got a = Miss (Dl.DList S.ByteString) | Got a
deriving Functor
instance Applicative Got where
pure = Got
Miss e1 <*> Miss e2 = Miss (e1 <> e2)
Miss e <*> _ = Miss e
_ <*> Miss e = Miss e
Got f <*> Got x = Got (f x)
gotEither :: Got a -> Either [S.ByteString] a
gotEither (Miss e) = Left (Dl.toList e)
gotEither (Got a) = Right a
instance Monoid a => Monoid (Got a) where
mempty = pure mempty
mappend = liftA2 mappend
runTemplate
:: (S.ByteString -> Maybe S.ByteString)
-> Template -> Either [S.ByteString] Sl.ByteString
runTemplate lookMay =
gotEither . fmap Sb.toLazyByteString
. F.foldMap get
. unTemplate
where
get (Literal b) = pure b
get (Hole name) = Sb.byteString <$> look name
look :: S.ByteString -> Got S.ByteString
look s = maybe (Miss (pure s)) Got (lookMay s)
showTemplate :: Template -> S.ByteString
showTemplate t =
case runTemplate (\s -> Just $ "{{" <> s <> "}}") t of
Left _ -> error "Impossible!"
Right s -> Sl.toStrict s
instance Show Template where
show = show . showTemplate
parseTemplate :: S.ByteString -> Either String Template
parseTemplate = A.parseOnly templateParser
instance IsString Template where
fromString s =
case parseTemplate (fromString s) of
Right a -> a
Left _ -> error ("Could not parse a Template: " ++ show s)
foldlM :: MonadPlus f => (b -> a -> b) -> b -> f a -> f b
foldlM mix seed gen = do
may <- liftM Just gen `mplus` return Nothing
case may of
Nothing -> return seed
Just a -> foldlM mix (mix seed a) gen
foldMonoidM :: (MonadPlus f, Monoid b) => (a -> b) -> f a -> f b
foldMonoidM f = foldlM (\b a -> b <> f a) mempty
templateParser :: A.Parser Template
templateParser = foldMonoidM (Template . pure) templateChunk
where
templateChunk :: A.Parser TemplateC
templateChunk =
A.choice [ hole, noBraces ]
noBraces :: A.Parser TemplateC
noBraces =
Literal . Sb.byteString <$> A.takeWhile1 (not . (== '{'))
singleBrace :: A.Parser TemplateC
singleBrace =
let build c = Literal (Sb.char8 '{' <> Sb.char8 c)
in build <$> A.try (A.char '{' *> A.satisfy (not . (== '{')))
hole :: A.Parser TemplateC
hole =
"{{" .*> A.skipSpace *>
(Hole <$> A.takeWhile1 (\c -> not (A.isSpace c || c == '}')))
<* A.skipSpace <*. "}}"