module Heist.Compiled.Internal where
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
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.HashSet as S
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 qualified Text.XmlHtml as X
import qualified Text.XmlHtml.HTML.Meta as X
import Heist.Common
import Heist.SpliceAPI
import Heist.Types
type Splice n = HeistT n IO (DList (Chunk n))
runChildren :: Monad n => Splice n
runChildren = runNodeList . X.childNodes =<< getParamNode
renderFragment :: Markup -> [X.Node] -> Builder
renderFragment markup ns =
case markup of
Html -> X.renderHtmlFragment X.UTF8 ns
Xml -> X.renderXmlFragment X.UTF8 ns
pureTextChunk :: Text -> Chunk n
pureTextChunk t = Pure $ T.encodeUtf8 t
yieldPure :: Builder -> DList (Chunk n)
yieldPure = DL.singleton . Pure . toByteString
yieldRuntime :: RuntimeSplice n Builder -> DList (Chunk n)
yieldRuntime = DL.singleton . RuntimeHtml
yieldRuntimeEffect :: Monad n => RuntimeSplice n () -> DList (Chunk n)
yieldRuntimeEffect = DL.singleton . RuntimeAction
yieldPureText :: Text -> DList (Chunk n)
yieldPureText = DL.singleton . pureTextChunk
yieldRuntimeText :: Monad n => RuntimeSplice n Text -> DList (Chunk n)
yieldRuntimeText = yieldRuntime . liftM fromText
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 <- evalHeistT splice node hs
return $! consolidate a
runDocumentFile :: Monad n
=> TPath
-> DocumentFile
-> Splice n
runDocumentFile tpath df = do
addDoctype $ maybeToList $ X.docType $ dfDoc df
modifyHS (setCurTemplateFile curPath . setCurContext tpath)
res <- runNodeList nodes
dt <- getsHS (listToMaybe . _doctypes)
let enc = X.docEncoding $ dfDoc df
return $! (yieldPure (X.renderDocType enc dt) `mappend` res)
where
curPath = dfFile df
nodes = X.docContent $! dfDoc df
compileTemplate :: Monad n
=> HeistState n
-> TPath
-> DocumentFile
-> IO [Chunk n]
compileTemplate hs tpath df = do
let markup = case dfDoc df of
X.XmlDocument _ _ _ -> Xml
X.HtmlDocument _ _ _ -> Html
hs' = hs { _curMarkup = markup }
!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 n
=> HeistState n
-> IO (H.HashMap TPath ([Chunk n], 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 n) => DList (Chunk n) -> [Chunk n]
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 n => DList (Chunk n) -> RuntimeSplice n 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
markup <- getsHS _curMarkup
if isStatic
then return $! yieldPure $! renderFragment markup [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 _ ) -> []
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) && nm `S.member` X.voidTags
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"
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
parseAtt2 :: Monad n
=> (Text, Text)
-> HeistT n IO (RuntimeSplice n [(Text, Text)])
parseAtt2 (k,v) = do
mas <- getsHS (H.lookup k . _attrSpliceMap)
maybe doInline (return . doAttrSplice) mas
where
cvt (Literal x) = return $ return x
cvt (Ident x) =
localParamNode (const $ X.Element x [] []) $ getAttributeSplice2 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
return $ do
list <- sequence chunks
return [(k, T.concat list)]
doAttrSplice splice = splice v
runAttributes :: Monad n
=> [(Text, Text)]
-> HeistT n IO [DList (Chunk n)]
runAttributes = mapM parseAtt
runAttributesRaw :: Monad n
=> [(Text, Text)]
-> HeistT n IO (RuntimeSplice n [(Text, Text)])
runAttributesRaw attrs = do
arrs <- mapM parseAtt2 attrs
return $ liftM concat $ sequence arrs
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
[ fromText " "
, fromText k
]
| otherwise = mconcat
[ fromText " "
, fromText k
, fromText "=\""
, fromText v
, fromText "\""
]
getAttributeSplice :: Text -> HeistT n IO (DList (Chunk n))
getAttributeSplice name =
lookupSplice name >>= fromMaybe
(return $ DL.singleton $ Pure $ T.encodeUtf8 $
T.concat ["${", name, "}"])
getAttributeSplice2 :: Monad n => Text -> HeistT n IO (RuntimeSplice n Text)
getAttributeSplice2 name = do
mSplice <- lookupSplice name
case mSplice of
Nothing -> return $ return $ T.concat ["${", name, "}"]
Just splice -> do
res <- splice
return $ liftM (T.decodeUtf8 . toByteString) $ codeGen res
newtype Promise a = Promise (HE.Key a)
getPromise :: (Monad n) => Promise a -> RuntimeSplice n 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 n) => Promise a -> a -> RuntimeSplice n ()
putPromise (Promise k) x = modify (HE.insert k x)
adjustPromise :: Monad n => Promise a -> (a -> a) -> RuntimeSplice n ()
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 :: Splices (Splice n)
-> HeistState n
-> HeistState n
bindSplices ss ts = foldr (uncurry bindSplice) ts $ splicesToList ss
withLocalSplices :: Splices (Splice n)
-> Splices (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
runNodeList $ maybe (error err) (X.docContent . dfDoc . fst) $
lookupTemplate nm hs _templateMap
where
err = "callTemplate: "++(T.unpack $ T.decodeUtf8 nm)++(" does not exist")
interpret :: Monad n => DList (Chunk n) -> n Builder
interpret = flip evalStateT HE.empty . unRT . codeGen
textSplice :: (a -> Text) -> a -> Builder
textSplice f = fromText . f
nodeSplice :: (a -> [X.Node]) -> a -> Builder
nodeSplice f = X.renderHtmlFragment X.UTF8 . f
pureSplice :: Monad n => (a -> Builder) -> RuntimeSplice n a -> Splice n
pureSplice f n = return $ yieldRuntime (return . f =<< n)
withSplices :: Monad n
=> Splice n
-> Splices (RuntimeSplice n a -> Splice n)
-> RuntimeSplice n a
-> Splice n
withSplices splice splices runtimeAction =
withLocalSplices splices' noSplices splice
where
splices' = mapS ($runtimeAction) splices
manyWithSplices :: Monad n
=> Splice n
-> Splices (RuntimeSplice n a -> Splice n)
-> RuntimeSplice n [a]
-> Splice n
manyWithSplices splice splices runtimeAction = do
p <- newEmptyPromise
let splices' = mapS ($ getPromise p) splices
chunks <- withLocalSplices splices' noSplices splice
return $ yieldRuntime $ do
items <- runtimeAction
res <- forM items $ \item -> putPromise p item >> codeGen chunks
return $ mconcat res
deferMany :: Monad n
=> (RuntimeSplice n a -> Splice n)
-> RuntimeSplice n [a]
-> Splice n
deferMany f getItems = do
promise <- newEmptyPromise
chunks <- f $ getPromise promise
return $ yieldRuntime $ do
items <- getItems
res <- forM items $ \item -> do
putPromise promise item
codeGen chunks
return $ mconcat res
deferMap :: Monad n
=> (a -> RuntimeSplice n b)
-> (RuntimeSplice n b -> Splice n)
-> RuntimeSplice n a -> Splice n
deferMap f pf n = do
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ putPromise p2 =<< f =<< n
res <- pf $ getPromise p2
return $ action `mappend` res
mayDeferMap :: Monad n
=> (a -> RuntimeSplice n (Maybe b))
-> (RuntimeSplice n b -> Splice n)
-> RuntimeSplice n a -> Splice n
mayDeferMap f pf n = do
p2 <- newEmptyPromise
action <- pf $ getPromise p2
return $ yieldRuntime $ do
mb <- f =<< n
case mb of
Nothing -> return mempty
Just b -> do
putPromise p2 b
codeGen action
bindLater :: (Monad n)
=> (a -> RuntimeSplice n Builder)
-> RuntimeSplice n a
-> Splice n
bindLater f p = return $ yieldRuntime $ f =<< p