brendanhay · alexbiehl · Aug 4, 2024 · Aug 4, 2024 · Aug 4, 2024 · Aug 4, 2024
diff --git a/cabal.project b/cabal.project
@@ -1,5 +1,5 @@
 -- Ensure deterministic package set.
-index-state: 2022-03-18T22:34:41Z
+index-state: 2024-07-25T06:14:14Z
 
 -- Writing environment files prevents reproducible builds.
 write-ghc-environment-files: never

diff --git a/lib/Text/EDE.hs b/lib/Text/EDE.hs
@@ -109,6 +109,9 @@ module Text.EDE
 
     -- ** Let Expressions
     -- $let
+
+    -- ** Set
+    -- $set
   )
 where
 
@@ -211,21 +214,27 @@ parseWith ::
   -- | Strict 'ByteString' template definition.
   ByteString ->
   m (Result Template)
-parseWith config f name =
-  result failure resolve
-    . Parser.runParser config name
+parseWith config f name input =
+  case Parser.runParser config name input of
+    Success (u, is', es', bs) -> do
+      is <- Foldable.foldrM include (Success (HashMap.singleton name u)) (HashMap.toList is')
+      es <- Foldable.foldrM extends (Success mempty) (HashMap.toList es')
+      pure (Template name u <$> is <*> es <*> pure bs)
+    Failure err ->
+      failure err
   where
-    resolve (u, is) =
-      Foldable.foldrM include (Success (HashMap.singleton name u)) (HashMap.toList is)
-        >>= result failure (success . Template name u)
-
     -- Presuming self is always in self's includes, see singleton above.
     -- FIXME: utilise the list of deltas for failures
     include (_, _) (Failure err) = failure err
     include (key, delta :| _) (Success ss) =
       f config key delta
         >>= result failure (success . mappend ss . _tmplIncl)
 
+    extends (_, _) (Failure err) = failure err
+    extends (key, delta :| _) (Success ss) =
+      f config key delta
+        >>= result failure (success . mappend ss . _tmplIncl)
+
 -- | 'HashMap' resolver for @include@ expressions.
 --
 -- The 'identifier' component of the @include@ expression is treated as a lookup
@@ -288,8 +297,12 @@ renderWith ::
   -- | Bindings to make available in the environment.
   HashMap Text Value ->
   Result Text.Lazy.Text
-renderWith fs (Template _ u ts) =
-  fmap Text.Builder.toLazyText . Eval.render ts fs u
+renderWith fs t =
+  fmap Text.Builder.toLazyText .
+    Eval.render
+      (_tmplIncl t <> _tmplExtends t)
+      fs
+      (_tmplExp t)
 
 -- | /See:/ 'parse'
 eitherParse :: ByteString -> Either String Template
@@ -696,3 +709,55 @@ eitherRenderWith fs t = eitherResult . renderWith fs t
 -- > {{ var }}
 -- > ...
 -- > {% endlet %}
+
+-- $set
+--
+-- You can also bind an identifier to whole templates which will be available within
+-- the following expression scope. The identifier will be available in subsequent template.
+--
+-- For example:
+--
+-- > {% set var %}
+-- >   ...
+-- > {% endset %}
+-- > ...
+-- > {{ var }}
+
+-- $block
+--
+-- Blocks are used for inheritance and act as both placeholders and replacements at the same time: The most powerful
+-- part of @ED-E@ is template inheritance. Template inheritance allows you to build a base "skeleton" template that
+-- contains all the common elements of your site and defines blocks that child templates can override.
+--
+-- Base template:
+--
+-- > <!doctype html>
+-- > {% block head %}
+-- > <title>{% block title %}{% endblock %}</title>
+-- > {% endblock %}
+-- > {% block body %}{% endblock %}
+--
+-- Child template:
+--
+-- > {% extends "base.html" %}
+-- > {% block title %}Index{% endblock %}
+-- > {% block head %}
+-- >  {{ super }}
+-- >  <style type="text/css">
+-- >   .important { color: #336699; }
+-- > </style>
+-- > {% endblock %}
+-- > {% block body %}
+-- >  <h1>Index</h1>
+-- >  <p class="important">
+-- >    Welcome to my awesome homepage.
+-- >  </p>
+-- > {% endblock %}
+--
+-- The @{% extends %}@ tag is the key here. It tells the template engine that this template "extends" another template.
+-- When the template system evaluates this template, it first locates the parent. The extends tag should be the first tag in the template.
+--
+-- As you can see it's also possible to render the contents of the parent block by calling super(). You can’t define multiple {% block %}
+-- tags with the same name in the same template. This limitation exists because a block tag works in “both” directions. That is, a block
+-- tag doesn’t just provide a placeholder to fill - it also defines the content that fills the placeholder in the parent. If there were two
+-- similarly-named {% block %} tags in a template, that template's parent wouldn’t know which one of the blocks’ content to use.
diff --git a/lib/Text/EDE/Internal/AST.hs b/lib/Text/EDE/Internal/AST.hs
@@ -57,6 +57,21 @@ elet :: Maybe (Id, Exp a) -> Exp a -> Exp a
 elet m e = maybe e (\(i, b) -> Comonad.extract b :< ELet i b e) m
 {-# INLINEABLE elet #-}
 
+eset :: Id -> Exp a -> Exp a -> Exp a
+eset i e k =
+  elet (Just (i, e)) k
+{-# INLINEABLE eset #-}
+
+eblock :: Id -> Exp a -> Exp a
+eblock i e =
+  Comonad.extract e :< EBlock i e
+{-# INLINEABLE eblock #-}
+
+eOverrideBlock :: Id -> Exp a -> Exp a -> Exp a
+eOverrideBlock i b e =
+  Comonad.extract b :< EOverrideBlock i b e
+{-# INLINEABLE eOverrideBlock #-}
+
 ecase ::
   Exp a ->
   [Alt (Exp a)] ->

diff --git a/lib/Text/EDE/Internal/Eval.hs b/lib/Text/EDE/Internal/Eval.hs
@@ -49,9 +49,11 @@ import Text.Trifecta.Delta (Delta)
 import qualified Text.Trifecta.Delta as Trifecta.Delta
 
 data Env = Env
-  { _templates :: HashMap Id (Exp Delta),
+  { _extends :: Bool,
+    _templates :: HashMap Id (Exp Delta),
     _quoted :: HashMap Id Term,
-    _values :: HashMap Id Value
+    _values :: HashMap Id Value,
+    _blocks :: HashMap Id (Exp Delta)
   }
 
 type Context = ReaderT Env Result
@@ -63,7 +65,7 @@ render ::
   HashMap Id Value ->
   Result Builder
 render ts fs e o =
-  Reader.runReaderT (eval e >>= nf) (Env ts (stdlib <> fs) o)
+  Reader.runReaderT (eval e >>= nf) (Env False ts (stdlib <> fs) o mempty)
   where
     nf (TVal v) = build (Trifecta.Delta.delta e) v
     nf _ =
@@ -85,6 +87,26 @@ eval (d :< EApp a b) = do
   x <- eval a
   y <- eval b
   binding d x y
+eval (d :< EOverrideBlock i b e) =
+  setExtended True $ do
+    q <- HashMap.lookup i <$> Reader.asks _blocks
+    case q of
+      Nothing ->
+        bindBlock (HashMap.insert i b) (eval e)
+      Just eb ->
+        bindBlock (HashMap.insert i (d :< ELet "super" b eb)) (eval e)
+eval (_ :< EBlock i b) = do
+  extends <- Reader.asks _extends
+  q <- HashMap.lookup i <$> Reader.asks _blocks
+  if extends then
+    pure (qprim (String mempty))
+  else do
+    x <- eval b
+    v <- lift (unquote i 0 x)
+    maybe
+      (pure x)
+      (bind (HashMap.insert "super" v) . eval)
+      q
 eval (_ :< ELet k rhs bdy) = do
   q <- eval rhs
   v <- lift (unquote k 0 q)
@@ -164,7 +186,21 @@ eval (_ :< ELoop i v bdy) = eval v >>= lift . unquote i 0 >>= loop
 eval (d :< EIncl i) = do
   ts <- Reader.asks _templates
   case HashMap.lookup i ts of
-    Just e -> eval e
+    Just e ->
+      -- Don't inherit any blocks declared so far.
+      setExtended False $
+        bindBlock (\_ -> mempty) (eval e)
+    Nothing ->
+      throwError d $
+        "template"
+          <+> bold (pp i)
+          <+> "is not in scope:"
+          <+> PP.brackets (pp (Text.intercalate "," $ HashMap.keys ts))
+eval (d :< EExt i) = do
+  ts <- Reader.asks _templates
+  case HashMap.lookup i ts of
+    Just e ->
+      setExtended False (eval e)
     Nothing ->
       throwError d $
         "template"
@@ -177,6 +213,15 @@ bind :: (HashMap Text Value -> HashMap Text Value) -> Context a -> Context a
 bind f = Reader.withReaderT (\x -> x {_values = f (_values x)})
 {-# INLINEABLE bind #-}
 
+bindBlock :: (HashMap Id (Exp Delta) -> HashMap Id (Exp Delta)) -> Context a -> Context a
+bindBlock f = Reader.withReaderT (\x -> x {_blocks = f (_blocks x)})
+{-# INLINEABLE bindBlock #-}
+
+setExtended :: Bool -> Context a -> Context a
+setExtended extends =
+  Reader.withReaderT (\x -> x { _extends = extends })
+{-# INLINEABLE setExtended #-}
+
 variable :: Delta -> Var -> Context Value
 variable d (Var is) =
   Reader.asks _values >>= go (NonEmpty.toList is) [] . Object . fromHashMapText

diff --git a/lib/Text/EDE/Internal/Parser.hs b/lib/Text/EDE/Internal/Parser.hs
@@ -35,7 +35,6 @@ import Control.Monad.State.Strict (MonadState, StateT)
 import qualified Control.Monad.State.Strict as State
 import Control.Monad.Trans (lift)
 import Data.Aeson.Types (Value (..))
-import qualified Data.Bifunctor as Bifunctor
 import Data.ByteString (ByteString)
 import qualified Data.Char as Char
 import Data.HashMap.Strict (HashMap)
@@ -64,7 +63,9 @@ import qualified Text.Trifecta.Delta as Trifecta.Delta
 
 data Env = Env
   { _settings :: !Syntax,
-    _includes :: HashMap Text (NonEmpty Delta)
+    _includes :: HashMap Text (NonEmpty Delta),
+    _extends :: HashMap Text (NonEmpty Delta),
+    _blocks :: HashMap Text (Exp Delta)
   }
 
 $(Lens.makeLenses ''Env)
@@ -120,15 +121,25 @@ runParser ::
   Syntax ->
   Text ->
   ByteString ->
-  Result (Exp Delta, HashMap Text (NonEmpty Delta))
+  Result (Exp Delta, HashMap Text (NonEmpty Delta), HashMap Text (NonEmpty Delta), HashMap Text (Exp Delta))
 runParser o n = res . Trifecta.parseByteString (runEDE run) pos
   where
-    run = State.runStateT (pragma *> document <* Trifecta.eof) (Env o mempty)
+    run = State.runStateT (pragma *> document <* Trifecta.eof) (Env o mempty mempty mempty)
 
     pos = Trifecta.Delta.Directed (Text.Encoding.encodeUtf8 n) 0 0 0 0
 
     res = \case
-      Trifecta.Success x -> Success (Bifunctor.second _includes x)
+      Trifecta.Success (x, env) ->
+        if null (_extends env) then
+          Success (x, _includes env, _extends env, _blocks env)
+        else
+          -- In case the template extends another template we arrange the contained
+          -- blocks in a way that make it easy to evaluate the "inheritance" mechanism.
+          let
+            x' =
+              HashMap.foldrWithKey eOverrideBlock x (_blocks env)
+          in
+            Success (x', _includes env, _extends env, _blocks env)
       Trifecta.Failure e -> Failure (Trifecta._errDoc e)
 
 pragma :: Parser m => m ()
@@ -184,6 +195,9 @@ statement =
       cases,
       loop,
       include,
+      set,
+      block',
+      extends',
       binding,
       raw,
       comment
@@ -257,6 +271,13 @@ include = block "include" $ do
         (,) <$> (keyword "with" *> identifier)
           <*> (Trifecta.symbol "=" *> term)
 
+extends' :: Parser m => m (Exp Delta)
+extends' = block "extends" $ do
+  d <- Trifecta.position
+  k <- Trifecta.stringLiteral
+  extends %= HashMap.insertWith (<>) k (d :| [])
+  pure (d :< EExt k)
+
 binding :: Parser m => m (Exp Delta)
 binding =
   elet . Just
@@ -268,6 +289,22 @@ binding =
     <*> document
     <* exit "endlet"
 
+set :: Parser m => m (Exp Delta)
+set =
+  eset
+  <$> block "set" identifier
+  <*> document
+  <* exit "endset"
+  <*> document
+
+block' :: Parser m => m (Exp Delta)
+block' = do
+  k <- block "block" identifier
+  e <- document
+  _ <- exit "endblock"
+  blocks %= HashMap.insert k e
+  pure (eblock k e)
+
 raw :: Parser m => m (Exp Delta)
 raw = ann (ELit <$> body)
   where

diff --git a/lib/Text/EDE/Internal/Syntax.hs b/lib/Text/EDE/Internal/Syntax.hs
@@ -104,7 +104,11 @@ keywordSet =
       "_",
       ".",
       "true",
-      "false"
+      "false",
+      "set",
+      "endset",
+      "block",
+      "endblock"
     ]
 
 pragmaStyle :: TokenParsing m => IdentifierStyle m

diff --git a/lib/Text/EDE/Internal/Types.hs b/lib/Text/EDE/Internal/Types.hs
@@ -166,7 +166,9 @@ type Resolver m = Syntax -> Id -> Delta -> m (Result Template)
 data Template = Template
   { _tmplName :: !Text,
     _tmplExp :: !(Exp Delta),
-    _tmplIncl :: HashMap Id (Exp Delta)
+    _tmplIncl :: HashMap Id (Exp Delta),
+    _tmplExtends :: HashMap Id (Exp Delta),
+    _tmplBlocks :: HashMap Id (Exp Delta)
   }
   deriving (Eq)
 
@@ -203,9 +205,12 @@ data ExpF a
   | EFun !Id
   | EApp !a !a
   | ELet !Id !a !a
+  | EBlock !Id !a
+  | EOverrideBlock !Id !a !a
   | ECase !a [Alt a]
   | ELoop !Id !a !a
   | EIncl !Text
+  | EExt !Text
   deriving (Eq, Show, Functor)
 
 instance Functor.Classes.Eq1 ExpF where
@@ -214,11 +219,14 @@ instance Functor.Classes.Eq1 ExpF where
   liftEq _ (EFun a) (EFun b) = a == b
   liftEq c (EApp a1 a2) (EApp b1 b2) = a1 `c` b1 && a2 `c` b2
   liftEq c (ELet a0 a1 a2) (ELet b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2
+  liftEq c (EBlock a0 a1) (EBlock b0 b1) = a0 == b0 && a1 `c` b1
+  liftEq c (EOverrideBlock a0 a1 a2) (EOverrideBlock b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2
   liftEq c (ECase a as) (ECase b bs) = a `c` b && (List.all (uncurry altEq) $ zip as bs)
     where
       altEq (pA, a') (pB, b') = pA == pB && a' `c` b'
   liftEq c (ELoop a0 a1 a2) (ELoop b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2
   liftEq _ (EIncl a) (EIncl b) = a == b
+  liftEq _ (EExt a) (EExt b) = a == b
   liftEq _ _ _ = False
 
 type Exp = Cofree ExpF

diff --git a/test/resources/ext-base.ede b/test/resources/ext-base.ede
@@ -0,0 +1,7 @@
+{}
+---
+<!doctype html>
+{% block head %}
+<title>{% block title %}{% endblock %}</title>
+{% endblock %}
+{% block body %}{% endblock %}
diff --git a/test/resources/ext-base.golden b/test/resources/ext-base.golden
@@ -0,0 +1,2 @@
+<!doctype html>
+<title></title>