module Heist.Compiled.Internal where
import Blaze.ByteString.Builder
import Control.Arrow
import Control.Monad
import Control.Monad.RWS.Strict
import Control.Monad.State.Strict
import qualified Data.Attoparsec.Text as AP
import Data.ByteString (ByteString)
import Data.DList (DList)
import qualified Data.DList as DL
import qualified Data.HashMap.Strict as H
import qualified Data.HeterogeneousEnvironment as HE
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import Prelude hiding (catch)
import qualified Text.XmlHtml as X
import Heist.Common
import Heist.Types
type Splice n = HeistT n IO (DList (Chunk n))
runChildren :: Monad n => Splice n
runChildren = runNodeList . X.childNodes =<< getParamNode
mapPromises :: Monad n
=> (Promise a -> HeistT n IO (RuntimeSplice n Builder))
-> RuntimeSplice n [a]
-> Splice n
mapPromises f getList = do
singlePromise <- newEmptyPromise
runSingle <- f singlePromise
return $ yieldRuntime $ do
list <- getList
htmls <- forM list $ \item ->
putPromise singlePromise item >> runSingle
return $ mconcat htmls
promiseChildren :: Monad m => HeistT m IO (RuntimeSplice m Builder)
promiseChildren = liftM codeGen runChildren
promiseChildrenWith :: (Monad n)
=> [(Text, a -> Builder)]
-> Promise a
-> HeistT n IO (RuntimeSplice n Builder)
promiseChildrenWith splices prom =
localHS (bindSplices splices') promiseChildren
where
fieldSplice p f = return $ yieldRuntime $ liftM f $ getPromise p
splices' = map (second (fieldSplice prom)) splices
promiseChildrenWithTrans :: Monad n
=> (b -> Builder)
-> [(Text, a -> b)]
-> Promise a
-> HeistT n IO (RuntimeSplice n Builder)
promiseChildrenWithTrans f = promiseChildrenWith . map (second (f .))
promiseChildrenWithText :: (Monad n)
=> [(Text, a -> Text)]
-> Promise a
-> HeistT n IO (RuntimeSplice n Builder)
promiseChildrenWithText =
promiseChildrenWithTrans (fromByteString . T.encodeUtf8)
promiseChildrenWithNodes :: (Monad n)
=> [(Text, a -> [X.Node])]
-> Promise a
-> HeistT n IO (RuntimeSplice n Builder)
promiseChildrenWithNodes =
promiseChildrenWithTrans (X.renderHtmlFragment X.UTF8)
pureTextChunk :: Text -> Chunk n
pureTextChunk t = Pure $ T.encodeUtf8 t
yieldPure :: Builder -> DList (Chunk m)
yieldPure = DL.singleton . Pure . toByteString
yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m)
yieldRuntime = DL.singleton . RuntimeHtml
yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m)
yieldRuntimeEffect = DL.singleton . RuntimeAction
yieldPureText :: Text -> DList (Chunk m)
yieldPureText = DL.singleton . pureTextChunk
yieldRuntimeText :: Monad m => RuntimeSplice m Text -> DList (Chunk m)
yieldRuntimeText = yieldRuntime . liftM (fromByteString . T.encodeUtf8)
yieldLater :: Monad m => m Builder -> DList (Chunk m)
yieldLater = yieldRuntime . RuntimeSplice . lift
runNodeList :: Monad n => [X.Node] -> Splice n
runNodeList = mapSplices runNode
runSplice :: (Monad n)
=> X.Node
-> HeistState n
-> Splice n
-> IO [Chunk n]
runSplice node hs splice = do
(!a,_) <- runHeistT splice node hs
return $! consolidate a
runDocumentFile :: Monad n
=> TPath
-> DocumentFile
-> Splice n
runDocumentFile tpath df = do
modifyHS (setCurTemplateFile curPath . setCurContext tpath)
runNodeList nodes
where
curPath = dfFile df
nodes = X.docContent $! dfDoc df
compileTemplate :: Monad n
=> HeistState n
-> TPath
-> DocumentFile
-> IO [Chunk n]
compileTemplate hs tpath df = do
!chunks <- runSplice nullNode hs $! runDocumentFile tpath df
return chunks
where
nullNode = X.TextNode ""
compileTemplates :: Monad n => HeistState n -> IO (HeistState n)
compileTemplates hs = do
ctm <- compileTemplates' hs
return $! hs { _compiledTemplateMap = ctm }
compileTemplates' :: Monad m
=> HeistState m
-> IO (H.HashMap TPath ([Chunk m], MIMEType))
compileTemplates' hs = do
ctm <- foldM runOne H.empty tpathDocfiles
return $! ctm
where
tpathDocfiles :: [(TPath, DocumentFile)]
tpathDocfiles = map (\(a,b) -> (a, b))
(H.toList $ _templateMap hs)
runOne tmap (tpath, df) = do
!mHtml <- compileTemplate hs tpath df
return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap
consolidate :: (Monad m) => DList (Chunk m) -> [Chunk m]
consolidate = consolidateL . DL.toList
where
consolidateL [] = []
consolidateL (y:ys) = boilDown [] $! go [] y ys
where
go soFar x [] = x : soFar
go soFar (Pure a) ((Pure b) : xs) =
go soFar (Pure $! a `mappend` b) xs
go soFar (RuntimeHtml a) ((RuntimeHtml b) : xs) =
go soFar (RuntimeHtml $! a `mappend` b) xs
go soFar (RuntimeHtml a) ((RuntimeAction b) : xs) =
go soFar (RuntimeHtml $! a >>= \x -> b >> return x) xs
go soFar (RuntimeAction a) ((RuntimeHtml b) : xs) =
go soFar (RuntimeHtml $! a >> b) xs
go soFar (RuntimeAction a) ((RuntimeAction b) : xs) =
go soFar (RuntimeAction $! a >> b) xs
go soFar a (b : xs) = go (a : soFar) b xs
boilDown soFar [] = soFar
boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs
boilDown soFar (x : xs) = boilDown (x : soFar) xs
codeGen :: Monad m => DList (Chunk m) -> RuntimeSplice m Builder
codeGen l = V.foldr mappend mempty $!
V.map toAct $! V.fromList $! consolidate l
where
toAct !(RuntimeHtml !m) = m
toAct !(Pure !h) = return $! fromByteString h
toAct !(RuntimeAction !m) = m >> return mempty
lookupSplice :: Text -> HeistT n IO (Maybe (Splice n))
lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap)
runNode :: Monad n => X.Node -> Splice n
runNode node = localParamNode (const node) $ do
isStatic <- subtreeIsStatic node
if isStatic
then return $! yieldPure $!
X.renderHtmlFragment X.UTF8 [parseAttrs node]
else compileNode node
parseAttrs :: X.Node -> X.Node
parseAttrs (X.Element nm attrs ch) = newAttrs `seq` X.Element nm newAttrs ch
where
newAttrs = map parseAttr attrs
parseAttrs !n = n
parseAttr :: (Text, Text) -> (Text, Text)
parseAttr (k,v) = (k, T.concat $! map cvt ast)
where
!ast = case AP.feed (AP.parse attParser v) "" of
(AP.Done _ res) -> res
(AP.Fail _ _ _) -> []
(AP.Partial _ ) -> []
cvt (Literal x) = x
cvt (Ident i) = T.concat ["${", i, "}"]
subtreeIsStatic :: X.Node -> HeistT n IO Bool
subtreeIsStatic (X.Element nm attrs ch) = do
isNodeDynamic <- liftM isJust $ lookupSplice nm
attrSplices <- getsHS _attrSpliceMap
let hasSubstitutions (k,v) = hasAttributeSubstitutions v ||
H.member k attrSplices
if isNodeDynamic
then return False
else do
let hasDynamicAttrs = any hasSubstitutions attrs
if hasDynamicAttrs
then return False
else do
staticSubtrees <- mapM subtreeIsStatic ch
return $ and staticSubtrees
subtreeIsStatic _ = return True
hasAttributeSubstitutions :: Text -> Bool
hasAttributeSubstitutions txt = any isIdent ast
where
ast = case AP.feed (AP.parse attParser txt) "" of
(AP.Done _ res) -> res
(AP.Fail _ _ _) -> []
(AP.Partial _ ) -> []
parseAtt :: Monad n => (Text, Text) -> HeistT n IO (DList (Chunk n))
parseAtt (k,v) = do
mas <- getsHS (H.lookup k . _attrSpliceMap)
maybe doInline (return . doAttrSplice) mas
where
cvt (Literal x) = return $ yieldPureText x
cvt (Ident x) =
localParamNode (const $ X.Element x [] []) $ getAttributeSplice x
doInline = do
let ast = case AP.feed (AP.parse attParser v) "" of
(AP.Done _ res) -> res
(AP.Fail _ _ _) -> []
(AP.Partial _ ) -> []
chunks <- mapM cvt ast
let value = DL.concat chunks
return $ attrToChunk k value
doAttrSplice splice = DL.singleton $ RuntimeHtml $ do
res <- splice v
return $ mconcat $ map attrToBuilder res
compileNode :: Monad n => X.Node -> Splice n
compileNode (X.Element nm attrs ch) =
lookupSplice nm >>= fromMaybe compileStaticElement
where
tag0 = T.append "<" nm
end = T.concat [ "</" , nm , ">"]
compileStaticElement = do
compiledAttrs <- runAttributes attrs
childHtml <- runNodeList ch
return $! if null (DL.toList childHtml)
then DL.concat [ DL.singleton $! pureTextChunk $! tag0
, DL.concat compiledAttrs
, DL.singleton $! pureTextChunk " />"
]
else DL.concat [ DL.singleton $! pureTextChunk $! tag0
, DL.concat compiledAttrs
, DL.singleton $! pureTextChunk ">"
, childHtml
, DL.singleton $! pureTextChunk $! end
]
compileNode _ = error "impossible"
runAttributes :: Monad n => [(Text, Text)] -> HeistT n IO [DList (Chunk n)]
runAttributes = mapM parseAtt
attrToChunk :: Text -> DList (Chunk n) -> DList (Chunk n)
attrToChunk !k !v = do
DL.concat
[ DL.singleton $! pureTextChunk $! T.concat [" ", k, "=\""]
, v, DL.singleton $! pureTextChunk "\"" ]
attrToBuilder :: (Text, Text) -> Builder
attrToBuilder (k,v)
| T.null v = mconcat
[ fromByteString $! T.encodeUtf8 " "
, fromByteString $! T.encodeUtf8 k
]
| otherwise = mconcat
[ fromByteString $! T.encodeUtf8 " "
, fromByteString $! T.encodeUtf8 k
, fromByteString $! T.encodeUtf8 "=\""
, fromByteString $! T.encodeUtf8 v
, fromByteString $! T.encodeUtf8 "\""
]
getAttributeSplice :: Text -> HeistT n IO (DList (Chunk n))
getAttributeSplice name =
lookupSplice name >>= fromMaybe
(return $ DL.singleton $ Pure $ T.encodeUtf8 $
T.concat ["${", name, "}"])
newtype Promise a = Promise (HE.Key a)
getPromise :: (Monad m) => Promise a -> RuntimeSplice m a
getPromise (Promise k) = do
mb <- gets (HE.lookup k)
return $ fromMaybe e mb
where
e = error $ "getPromise: dereferenced empty key (id "
++ show (HE.getKeyId k) ++ ")"
putPromise :: (Monad m) => Promise a -> a -> RuntimeSplice m ()
putPromise (Promise k) x = modify (HE.insert k x)
adjustPromise :: Monad m => Promise a -> (a -> a) -> RuntimeSplice m ()
adjustPromise (Promise k) f = modify (HE.adjust f k)
newEmptyPromise :: HeistT n IO (Promise a)
newEmptyPromise = do
keygen <- getsHS _keygen
key <- liftIO $ HE.makeKey keygen
return $! Promise key
bindSplice :: Text
-> Splice n
-> HeistState n
-> HeistState n
bindSplice n v ts =
ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap ts) }
bindSplices :: [(Text, Splice n)]
-> HeistState n
-> HeistState n
bindSplices ss ts = foldr (uncurry bindSplice) ts ss
addSplices :: Monad m => [(Text, Splice n)] -> HeistT n m ()
addSplices ss = modifyHS (bindSplices ss)
withLocalSplices :: [(Text, Splice n)]
-> [(Text, AttrSplice n)]
-> HeistT n IO a
-> HeistT n IO a
withLocalSplices ss as = localHS (bindSplices ss . bindAttributeSplices as)
renderTemplate :: Monad n
=> HeistState n
-> ByteString
-> Maybe (n Builder, MIMEType)
renderTemplate hs nm =
fmap (first (interpret . DL.fromList) . fst) $!
lookupTemplate nm hs _compiledTemplateMap
callTemplate :: Monad n
=> ByteString
-> HeistT n IO (DList (Chunk n))
callTemplate nm = do
hs <- getHS
return $ maybe DL.empty (DL.fromList . fst . fst) $
lookupTemplate nm hs _compiledTemplateMap
interpret :: Monad m => DList (Chunk m) -> m Builder
interpret = flip evalStateT HE.empty . unRT . codeGen
mapSnd :: (b -> c) -> [(d, b)] -> [(d, c)]
mapSnd = map . second
applySnd :: a -> [(d, a -> b)] -> [(d, b)]
applySnd a = mapSnd ($a)
textSplices :: [(Text, a -> Text)] -> [(Text, a -> Builder)]
textSplices = mapSnd textSplice
textSplice :: (a -> Text) -> a -> Builder
textSplice f = fromByteString . T.encodeUtf8 . f
nodeSplices :: [(Text, a -> [X.Node])] -> [(Text, a -> Builder)]
nodeSplices = mapSnd nodeSplice
nodeSplice :: (a -> [X.Node]) -> a -> Builder
nodeSplice f = X.renderHtmlFragment X.UTF8 . f
pureSplices :: Monad m => [(d, a -> Builder)] -> [(d, Promise a -> Splice m)]
pureSplices = mapSnd pureSplice
pureSplice :: Monad m => (a -> Builder) -> Promise a -> Splice m
pureSplice f p = do
return $ yieldRuntime $ do
a <- getPromise p
return $ f a
mapInputPromise :: Monad m
=> (a -> b)
-> (Promise b -> Splice m)
-> Promise a -> Splice m
mapInputPromise f g p1 = do
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ do
a <- getPromise p1
putPromise p2 (f a)
res <- g p2
return $ action `mappend` res
defer :: Monad n
=> (Promise a -> Splice n)
-> RuntimeSplice n a
-> Splice n
defer f getItem = do
promise <- newEmptyPromise
chunks <- f promise
return $ yieldRuntime $ do
item <- getItem
putPromise promise item
codeGen chunks
deferMany :: Monad n
=> (Promise a -> Splice n)
-> RuntimeSplice n [a]
-> Splice n
deferMany f getItems = do
promise <- newEmptyPromise
chunks <- f promise
return $ yieldRuntime $ do
items <- getItems
res <- forM items $ \item -> do
putPromise promise item
codeGen chunks
return $ mconcat res
withSplices :: Monad n
=> Splice n
-> [(Text, Promise a -> Splice n)]
-> n a
-> Splice n
withSplices splice splices runtimeAction = do
p <- newEmptyPromise
let splices' = mapSnd ($p) splices
chunks <- withLocalSplices splices' [] splice
let fillPromise = yieldRuntimeEffect $ putPromise p =<< lift runtimeAction
return $ fillPromise `mappend` chunks
manyWithSplices :: Monad n
=> Splice n
-> [(Text, Promise a -> Splice n)]
-> n [a]
-> Splice n
manyWithSplices splice splices runtimeAction = do
p <- newEmptyPromise
let splices' = mapSnd ($p) splices
chunks <- withLocalSplices splices' [] splice
return $ yieldRuntime $ do
items <- lift runtimeAction
res <- forM items $ \item -> putPromise p item >> codeGen chunks
return $ mconcat res
withPureSplices :: Monad n
=> Splice n
-> [(Text, a -> Builder)]
-> n a
-> Splice n
withPureSplices splice splices action = do
let fieldSplice g = return $ yieldRuntime $ liftM g $ lift action
let splices' = map (second fieldSplice) splices
withLocalSplices splices' [] splice