heist-0.13.0.2/0000755000000000000000000000000012226547635011251 5ustar0000000000000000heist-0.13.0.2/.ghci0000644000000000000000000000014512226547635012164 0ustar0000000000000000:set -XOverloadedStrings :set -Wall :set -isrc :set -itest/suite :set -hide-package MonadCatchIO-mtl heist-0.13.0.2/CONTRIBUTORS0000644000000000000000000000041612226547635013132 0ustar0000000000000000Doug Beardsley Gregory Collins Carl Howells Edward Kmett Will Langstroth Shane O'Brien James Sanders Mark Wright heist-0.13.0.2/haddock.sh0000755000000000000000000000044512226547635013210 0ustar0000000000000000#!/bin/sh set -x HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html --css=extra/haddock.css' cabal haddock $HADDOCK_OPTS --hyperlink-source $@ cp extra/logo.gif dist/doc/html/heist/haskell_icon.gif cp extra/hscolour.css dist/doc/html/heist/src/ heist-0.13.0.2/heist.cabal0000644000000000000000000001325412226547635013356 0ustar0000000000000000name: heist version: 0.13.0.2 synopsis: An Haskell template system supporting both HTML5 and XML. description: Heist is a powerful template system that supports both HTML5 and XML. Some of Heist's features are: . * Designer-friendly HTML5 (or XML) syntax . * Templates can be reloaded to make changes visible without recompiling your Haskell code . * Enforces near-perfect separation of business logic and view . * Powerful abstraction primitives allowing you to eliminate repetition . * Easy creation of domain-specific markup languages . * Built-in support for including JSON and Markdown content in templates . * Simple mechanism for designer-specified template caching . * Optional merging of multiple \ tags defined anywhere in the document license: BSD3 license-file: LICENSE author: Doug Beardsley, Gregory Collins maintainer: snap@snapframework.com build-type: Simple cabal-version: >= 1.6 homepage: http://snapframework.com/ category: Web, Snap extra-source-files: .ghci, CONTRIBUTORS, docs/Makefile, docs/templates.css, docs/templates.md, examples/ex01/home.tpl, examples/ex01/nav.tpl, examples/ex02/default.tpl, examples/ex02/home.tpl, examples/ex03/default.tpl, examples/ex03/home.tpl, examples/test01.tpl, examples/test02.tpl, extra/haddock.css, extra/hscolour.css, extra/logo.gif, haddock.sh, LICENSE, README.md, README.SNAP.md, test/.ghci, test/heist-testsuite.cabal, test/README, test/runTestsAndCoverage.sh, test/suite/Benchmark.hs, test/suite/Heist/Compiled/Tests.hs, test/suite/Heist/Interpreted/Tests.hs, test/suite/Heist/TestCommon.hs, test/suite/Heist/Tests.hs, test/suite/Heist/Tutorial/AttributeSplices.lhs, test/suite/Heist/Tutorial/CompiledSplices.lhs, test/suite/Heist/Tutorial/Imports.hs, test/suite/TestSuite.hs, test/templates/a.tpl, test/templates/attr_splice.tpl, test/templates/attrs.tpl, test/templates/attrsubtest1.tpl, test/templates/attrsubtest2.tpl, test/templates/bar/a.tpl, test/templates/bar/index.tpl, test/templates/bind-apply-interaction/_outer.tpl, test/templates/bind-apply-interaction/caller.tpl, test/templates/bind-attrs.tpl, test/templates/bind_param.tpl, test/templates/cache.tpl, test/templates/div_expansion.tpl, test/templates/foo/a.tpl, test/templates/foo/b.tpl, test/templates/foo/markdown-chdir.tpl, test/templates/foo/markdown-origdir.tpl, test/templates/foo/test2.md, test/templates/head_merge/index.tpl, test/templates/head_merge/nav.tpl, test/templates/head_merge/wrap.tpl, test/templates/index.tpl, test/templates/ioc.tpl, test/templates/json.tpl, test/templates/json_object.tpl, test/templates/json_snippet.tpl, test/templates/markdown.tpl, test/templates/page.tpl, test/templates/people.tpl, test/templates/post.tpl, test/templates/readme.txt, test/templates/test.md, test/templates/textarea_expansion.tpl, test/templates/title_expansion.tpl, test/templates/user/admin/main.tpl, test/templates/user/admin/menu.tpl, test/templates/user/main.tpl, test/templates/user/menu.tpl, test/templates-bad/apply-missing-attr.tpl, test/templates-bad/apply-template-not-found.tpl, test/templates-bad/bind-infinite-loop.tpl, test/templates-bad/bind-missing-attr.tpl, TODO Library hs-source-dirs: src exposed-modules: Heist, Heist.Compiled, Heist.Compiled.LowLevel, Heist.Interpreted, Heist.SpliceAPI, Heist.Splices, Heist.Splices.Apply, Heist.Splices.Bind, Heist.Splices.BindStrict, Heist.Splices.Cache, Heist.Splices.Html, Heist.Splices.Ignore, Heist.Splices.Json, Heist.Splices.Markdown, Heist.TemplateDirectory other-modules: Data.HeterogeneousEnvironment, Heist.Common, Heist.Compiled.Internal, Heist.Interpreted.Internal, Heist.Types build-depends: MonadCatchIO-transformers >= 0.2.1 && < 0.4, aeson >= 0.6 && < 0.7, attoparsec >= 0.10 && < 0.11, base >= 4 && < 5, blaze-builder >= 0.2 && < 0.4, blaze-html >= 0.4 && < 0.7, bytestring >= 0.9 && < 0.11, containers >= 0.2 && < 0.6, directory >= 1.1 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, errors >= 1.4 && < 1.5, filepath >= 1.3 && < 1.4, hashable >= 1.1 && < 1.3, mtl >= 2.0 && < 2.2, process >= 1.1 && < 1.2, random >= 1.0.1.0 && < 1.1, text >= 0.10 && < 0.12, time >= 1.1 && < 1.5, transformers >= 0.3 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, xmlhtml >= 0.2.3 && < 0.3 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 ghc-prof-options: -prof -auto-all Extensions: GeneralizedNewtypeDeriving, PackageImports, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, TypeSynonymInstances, NoMonomorphismRestriction source-repository head type: git location: https://github.com/snapframework/heist.git heist-0.13.0.2/LICENSE0000644000000000000000000000274512226547635012266 0ustar0000000000000000Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the Snap Framework authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. heist-0.13.0.2/README.md0000644000000000000000000000263412226547635012535 0ustar0000000000000000# Heist Heist, part of the [Snap Framework](http://www.snapframework.com/), is a Haskell library for xml/html templating. It uses simple XML tags to bind values to your templates in a straightforward way. For example, if you were to put the following in a template: some text

the resulting xhtml would be

some text

Likewise, if you need to add text to an attribute, special-id
very special
gives you
very special
Values can also be pulled from "Splices" (see [the documentation](http://snapframework.com/docs/tutorials/heist#heist-programming) for more information.) ## Building heist The heist library is built using [Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run cabal install from the `heist` toplevel directory. ## Building the Haddock Documentation The haddock documentation can be built using the supplied `haddock.sh` shell script: ./haddock.sh The docs get put in `dist/doc/html/`. ## Building the testsuite To build the test suite, `cd` into the `test/` directory and run $ cabal configure $ cabal build From here you can invoke the testsuite by running: $ ./runTestsAndCoverage.sh The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. heist-0.13.0.2/README.SNAP.md0000644000000000000000000000227312226547635013274 0ustar0000000000000000Snap Framework -------------- Snap is a simple and fast web development framework and server written in Haskell. For more information or to download the latest version, you can visit the Snap project website at http://snapframework.com/. Snap Status and Features ------------------------ The Snap core system consists of: * a high-speed HTTP server, with an optional high-concurrency backend using the [libev](http://software.schmorp.de/pkg/libev.html) library * a sensible and clean monad for web programming * an xml-based templating system for generating HTML that allows you to bind Haskell functionality to XML tags without getting PHP-style tag soup all over your pants * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. Snap Philosophy --------------- Snap aims to be the *de facto* web toolkit for Haskell, on the basis of: * High performance * High design standards * Simplicity and ease of use, even for Haskell beginners * Excellent documentation * Robustness and high test coverage heist-0.13.0.2/Setup.hs0000644000000000000000000000005712226547635012707 0ustar0000000000000000import Distribution.Simple main = defaultMain heist-0.13.0.2/TODO0000644000000000000000000000017412226547635011743 0ustar0000000000000000* Fix handling of ".." in apply tags Ongoing ------- * Improve test coverage * Head merging (ala the Lift Web Framework) heist-0.13.0.2/docs/0000755000000000000000000000000012226547635012201 5ustar0000000000000000heist-0.13.0.2/docs/Makefile0000644000000000000000000000031512226547635013640 0ustar0000000000000000all: out/templates.html clean: rm -Rf out out/templates.html: templates.md templates.css mkdir -p out cp templates.css out/ pandoc -c templates.css -s -f markdown -o out/templates.html templates.md heist-0.13.0.2/docs/templates.css0000644000000000000000000000113712226547635014713 0ustar0000000000000000body{ font-size: 12pt; color:#2c558a; background:#fdfeff; width: 75ex; margin:0 auto; font-family: "Helvetica Neue", "Arial", "Helvetica", sans-serif; } a:link, a:visited, a:active, a:hover{ text-decoration: none; } a:link, a:visited { color: #3d3dff; } a:hover { color: #622c8c; } a:active { color: #8c2c85; } h1,h2,h3{ font-weight:normal; color:#2c558a; letter-spacing:-0.02em; } h1{ font-size:2em; } h2{ font-size:1.5em; } h3{ font-weight: bold; } p{ line-height:1.7em; text-align: justify; } ul li{ padding: 0.5em 0em; } heist-0.13.0.2/docs/templates.md0000644000000000000000000002267612226547635014536 0ustar0000000000000000## Heist Templates Heist templates serve two primary design goals. First, they facilitate the separation of the view from the other aspects of your application. Second, they provide abstraction capabilities that allow you to avoid repeated template code. This allows you to follow the DRY principle (Don't Repeat Yourself) in the development of your application views. Heist has two primary template abstraction constructs: bind and apply. They are implemented as specialized XML tags. ### The `` tag The `bind` tag allows you to bind XML content to a single tag. Whenever the bound tag is used, the template engine will substitute the 'bind' tag's child nodes in its place. This allows you to essentially create your own higher-level markup language that Heist transforms into whatever XML-based markup language is native to your application. #### Attributes The `bind` tag has a single required attribute called `tag` specifying the name of the bound tag. If this attribute is not present, then the `bind` tag has no effect. #### Example Here's a simple example demonstrating the use of bind. ~~~~~~~~~~~~~~~ {.html} Einstein, Feynman, Heisenberg, and Newton Reasearch Corporation Ltd.TM We at have research expertise in many areas of physics. Employment at carries significant prestige. The rigorous hiring process developed by is leading the industry. ~~~~~~~~~~~~~~~ The full company name will be substituted at every occurrance of the `` tag. This eliminates repetition and makes it easier to make changes. ### The `` tag The `apply` tag loads one of your application templates and inserts it into the current template's XML tree. If the target template does not have any special tags, then the contents of the `apply` tag are ignored. #### Attributes The `apply` tag has one required attribute called `template`. This attribute specifies the name of the template being applied. Heist template names work a little differently from traditional paths and filenames. If the template name contains a '/' character, then it will behave like traditional relative and absolute paths. The root directory will be the root of your template directory tree, and the current directory will be the directory containing whatever template is currently being processed. Absolute template path names start at the root directory. Relative template path names start at the current directory. If the template name does not have any '/' characters, then Heist searches in the current directory for a template with that name. If it finds one, then Heist applies the template just like you would expect. The different behavior is that if the named template is not found in the current directory, Heist recursively searches up the directory hierarchy looking for the name. Heist uses the first template it finds on the way up that has that name. If no template is found, then you'll get an error. This cascading behavior allows you to put site-wide templates in the top-level directory and selectively override them in subdirectories for certain parts of your site. #### Example Let's look at a simple example to demonstrate the most basic use of the `apply` tag. Say you have a navigation menu that is used on many different pages of your site. You want to avoid duplicating the HTML code in multiple different page templates, so you might put it in a template file by itself called `nav.tpl` that looks like this: ~~~~~~~~~~~~~~~ {.html} ~~~~~~~~~~~~~~~ Then to include this nav template in your front page template, you would use the `apply` tag. Here is what a simple home page template `home.tpl` might look like: ~~~~~~~~~~~~~~~ {.html} Home Page

Home Page

Welcome to our home page

~~~~~~~~~~~~~~~ When a user requests the `/home` URL, Heist would serve `home.tpl`, and the nav template would automatically be inserted into the page. Here is what the HTML will look like after Heist processes the template: ~~~~~~~~~~~~~~~ {.html} Home Page

Home Page

Welcome to our home page

~~~~~~~~~~~~~~~ ### The `` tag Sometimes it is useful to pass information (usually in the form of XML data) into the template when it is applied so the template can insert it in useful places. This allows you to build page templates that are not just static blocks of code. If you are a programmer, you can think of a template as if it was a function that could have any number of parameters. In our previous example, we did not pass any parameters to the `nav` template when it was applied, so the `` tag was empty. If we include data inside the body of the `` tag, the template being called can access this data with the `` tag. The following simple example illustrates this concept. We create a site template called `default.tpl`: ~~~~~~~~~~~~~~~ {.html} Home Page
~~~~~~~~~~~~~~~ The `` tag "pulls in" the page content from the calling template and inserts it into the content `
`. Now we have a template for our home page called home.tpl: ~~~~~~~~~~~~~~~ {.html}

Home Page

Welcome to XYZ Inc

 ~~~~~~~~~~~~~~~ And when Heist receives a request to `/home`, it will serve the following: ~~~~~~~~~~~~~~~ {.html} Home Page

Home Page

Welcome to XYZ Inc

~~~~~~~~~~~~~~~ The two lines from inside the `` tag have been substituted into the content div in `default.tpl`. Notice the difference between these two examples. In the first example we pulled in a template (`nav.tpl`) that went inside the page being served (`home.tpl`). In the second example, `home.tpl` is still the intended target of requests, but the `default.tpl` template surrounds the content that home.tpl supplies as an argument. This seems like different behavior, but it is just a different use of the same `apply` tag. This illustrates the power of a simple concept like `apply`. ### Using Bind and Apply What if, in the above example, we decided that the contents of the header div should be different for different pages? To do this, we need a way to pass multiple parameters into a template. Heist provides this capability with the `` tag. Inside the body of a `` tag, you can have multiple bind tags surrounding data to be passed as separate parameters. Each `` tag must have a `tag` attribute that provides a name for its contents just as described above. Then, inside the template, those tags will be substituted with the appropriate data. The previous example only needs a few modifications to `default.tpl` to allow multiple parameters. ~~~~~~~~~~~~~~~ {.html} Home Page
~~~~~~~~~~~~~~~ And `home.tpl` uses the `` tag with a name attribute to define values for the `
` and `
` tags: ~~~~~~~~~~~~~~~ {.html}

XYZ Inc.

 Some in-between text.

Home Page

Welcome to XYZ Inc

 ~~~~~~~~~~~~~~~ The result template for this example is the same as the previous example. NOTE: In this example the `` tag is still bound as described above. The `` tag is always bound to the complete contents of the calling `apply` tag. However, any `bind` tags inside the apply will disappear. If we changed `default.tpl` to the following: ~~~~~~~~~~~~~~~ {.html} ~~~~~~~~~~~~~~~ Then the above `home.tpl` template would render like this: ~~~~~~~~~~~~~~~ {.html} Some in-between text. ~~~~~~~~~~~~~~~ ### The `` tag In some cases you may want to include example data in a Heist template that should not be rendered when the site is active. Heist provides the `` tag for this purpose. All `` tags and their contents will be eliminated in a template's output. ### The `` tag XML requires that well-formed documents have a single root element. Sometimes you might want to make templates that don't have a single root element. In these situations the `` tag is just what you want. When the children tag is rendered, it strips itself off and just returns its child nodes. This allows you to have a single root element where necessary, but have that tag disappear in the rendered output. heist-0.13.0.2/examples/0000755000000000000000000000000012226547635013067 5ustar0000000000000000heist-0.13.0.2/examples/test01.tpl0000644000000000000000000000011312226547635014723 0ustar0000000000000000bar heist-0.13.0.2/examples/test02.tpl0000644000000000000000000000016312226547635014731 0ustar0000000000000000*** This is a test of the emergency broadcasting system. heist-0.13.0.2/examples/ex01/0000755000000000000000000000000012226547635013644 5ustar0000000000000000heist-0.13.0.2/examples/ex01/home.tpl0000644000000000000000000000025712226547635015321 0ustar0000000000000000 Home Page

Home Page

Welcome to our home page.

heist-0.13.0.2/examples/ex01/nav.tpl0000644000000000000000000000016712226547635015155 0ustar0000000000000000 heist-0.13.0.2/examples/ex02/0000755000000000000000000000000012226547635013645 5ustar0000000000000000heist-0.13.0.2/examples/ex02/default.tpl0000644000000000000000000000037612226547635016020 0ustar0000000000000000 Home Page
heist-0.13.0.2/examples/ex02/home.tpl0000644000000000000000000000013212226547635015312 0ustar0000000000000000

Home Page

Welcome to XYZ Inc

 heist-0.13.0.2/examples/ex03/0000755000000000000000000000000012226547635013646 5ustar0000000000000000heist-0.13.0.2/examples/ex03/default.tpl0000644000000000000000000000036312226547635016015 0ustar0000000000000000 Home Page
heist-0.13.0.2/examples/ex03/home.tpl0000644000000000000000000000026212226547635015317 0ustar0000000000000000

XYZ Inc.

Home Page

Welcome to XYZ Inc

 heist-0.13.0.2/extra/0000755000000000000000000000000012226547635012374 5ustar0000000000000000heist-0.13.0.2/extra/haddock.css0000644000000000000000000002023112226547635014501 0ustar0000000000000000/* -------- Global things --------- */ HTML { background-color: #f0f3ff; width: 100%; } BODY { -moz-border-radius:5px; -webkit-border-radius:5px; width: 50em; margin: 2em auto; padding: 0; background-color: #ffffff; color: #000000; font-size: 110%; font-family: Georgia, serif; } A:link { color: #5200A3; text-decoration: none } A:visited { color: #5200A3; text-decoration: none } A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; } TABLE.vanilla { width: 100%; border-width: 0px; /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ } DL { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; letter-spacing: -0.01em; margin: 0; } .vanilla .vanilla dl { font-size: 80%; } .vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; } TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL { padding: 0 30px 0 34px; } TABLE.vanilla2 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; border-width: 0px; } /* font is a little too small in MSIE */ TT, PRE, CODE { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; font-size: 90%; } LI P { margin: 0pt } P { margin-top: 0; margin-bottom: 0.75em; } TD { border-width: 0px; } TABLE.narrow { border-width: 0px; } TD.s8 { height: 0; margin:0; padding: 0 } TD.s15 { height: 20px; } SPAN.keyword { text-decoration: underline; } /* Resize the buttom image to match the text size */ IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } /* --------- Contents page ---------- */ DIV.node { padding-left: 3em; } DIV.cnode { padding-left: 1.75em; } SPAN.pkg { position: absolute; left: 50em; } /* --------- Documentation elements ---------- */ TD FONT { font-weight: bold; letter-spacing: -0.02em; } TD.children { padding-left: 25px; } TD.synopsis { padding: 2px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } TD.decl { padding: 4px 8px; background-color: #FAFAFA; border-bottom: #F2F2F2 solid 1px; border-top: #FCFCFC solid 1px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; } TD.decl TD.decl { font-size: 100%; padding: 4px 0; border: 0; } TD.topdecl { padding: 20px 30px 0.5ex 30px; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; ; vertical-align: top; } .vanilla .vanilla .vanilla .topdecl { padding-left: 0; padding-right: 0; } .vanilla .vanilla .vanilla { padding-left: 30px; } .decl .vanilla { padding-left: 0px !important; } .body .vanilla .body { padding-left: 0; padding-right: 0; } .body .vanilla .body .decl { padding-left: 12px; } .body .vanilla .body div .vanilla .decl { padding-left: 12px; } TABLE.declbar { background-color: #f0f0f0; border-spacing: 0px; border-bottom:1px solid #d7d7df; border-right:1px solid #d7d7df; border-top:1px solid #f4f4f9; border-left:1px solid #f4f4f9; padding: 4px; } TD.declname { width: 100%; padding-right: 4px; } TD.declbut { padding-left: 8px; padding-right: 5px; border-left-width: 1px; border-left-color: #000099; border-left-style: solid; white-space: nowrap; font-size: x-small; } /* arg is just like decl, except that wrapping is not allowed. It is used for function and constructor arguments which have a text box to the right, where if wrapping is allowed the text box squashes up the declaration by wrapping it. */ TD.arg { padding: 2px 12px; background-color: #f0f0f0; font-size: 80%; font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; vertical-align: top; white-space: nowrap; } TD.recfield { padding-left: 20px } TD.doc { padding-left: 38px; font-size: 95%; line-height: 1.66; } TD.ndoc { font-size: 95%; line-height: 1.66; padding: 2px 4px 2px 8px; } TD.rdoc { padding: 2px; padding-left: 30px; width: 100%; font-size: 80%; font-style: italic; font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.body { padding: 0 30px; } TD.pkg { width: 100%; padding-left: 30px } TABLE.indexsearch TR.indexrow { display: none; } TABLE.indexsearch TR.indexshow { display: table-row; } TD.indexentry { vertical-align: top; padding: 0 30px } TD.indexannot { vertical-align: top; padding-left: 20px; white-space: nowrap } TD.indexlinks { width: 100% } /* ------- Section Headings ------- */ TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; } TD.section1 { padding-top: 14px; font-weight: bold; letter-spacing: -0.02em; font-size: 140% } TD.section2 { padding-top: 4px; font-weight: bold; letter-spacing: -0.02em; font-size: 120% } TD.section3 { padding-top: 5px; font-weight: bold; letter-spacing: -0.02em; font-size: 105% } TD.section4 { font-weight: bold; padding-top: 12px; padding-bottom: 4px; letter-spacing: -0.02em; font-size: 90% } /* -------------- The title bar at the top of the page */ TD.infohead { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; font-weight: bold; padding: 0 30px; text-align: left; } TD.infoval { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding: 0 30px; text-align: left; } TD.topbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; background-color: #3465a4; padding: 5px; -moz-border-radius-topleft:5px; -moz-border-radius-topright:5px; -webkit-border-radius-topleft:5px; -webkit-border-radius-topright:5px; } TD.title { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #ffffff; padding-left: 30px; letter-spacing: -0.02em; font-weight: bold; width: 100% } TD.topbut { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; padding-left: 5px; padding-right: 5px; border-left-width: 1px; border-left-color: #ffffff; border-left-style: solid; letter-spacing: -0.02em; font-weight: bold; white-space: nowrap; } TD.topbut A:link { color: #ffffff } TD.topbut A:visited { color: #ffff00 } TD.topbut A:hover { background-color: #C9D3DE; } TD.topbut:hover { background-color: #C9D3DE; } TD.modulebar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; color: #141B24; background-color: #C9D3DE; padding: 5px; border-top-width: 1px; border-top-color: #ffffff; border-top-style: solid; -moz-border-radius-bottomleft:5px; -moz-border-radius-bottomright:5px; -webkit-border-radius-bottomleft:5px; -webkit-border-radius-bottomright:5px; } /* --------- The page footer --------- */ TD.botbar { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; -moz-border-radius:5px; -webkit-border-radius:5px; background-color: #3465a4; color: #ffffff; padding: 5px } TD.botbar A:link { color: #ffffff; text-decoration: underline } TD.botbar A:visited { color: #ffff00 } TD.botbar A:hover { background-color: #6060ff } /* --------- Mini Synopsis for Frame View --------- */ .outer { margin: 0 0; padding: 0 0; } .mini-synopsis { padding: 0.25em 0.25em; } .mini-synopsis H1 { font-size: 120%; } .mini-synopsis H2 { font-size: 107%; } .mini-synopsis H3 { font-size: 100%; } .mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif; margin-top: 0.5em; margin-bottom: 0.25em; padding: 0 0; font-weight: bold; letter-spacing: -0.02em; } .mini-synopsis H1 { border-bottom: 1px solid #ccc; } .mini-topbar { font-size: 120%; background: #0077dd; padding: 0.25em; } heist-0.13.0.2/extra/hscolour.css0000644000000000000000000000073712226547635014753 0ustar0000000000000000body { font-size: 90%; } pre, code, body { font-family: Monaco, "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Lucida Console", monospace; } .hs-keyglyph, .hs-layout {color: #5200A3;} .hs-keyword {color: #3465a4; font-weight: bold;} .hs-comment, .hs-comment a {color: #579; } .hs-str, .hs-chr {color: #141B24;} .hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} heist-0.13.0.2/extra/logo.gif0000644000000000000000000000113712226547635014025 0ustar0000000000000000GIF89a` J"K#M%N(P1W1X3Z6\?d4e=i9i:j Splices (I.Splice m) defaultLoadTimeSplices = -- To be removed in later versions insertS "content" deprecatedContentCheck defaultInterpretedSplices ------------------------------------------------------------------------------ -- | The built-in set of static splices. All the splices that used to be -- enabled by default are included here. To get the normal Heist behavior you -- should include these in the hcLoadTimeSplices list in your HeistConfig. If -- you are using interpreted splice mode, then you might also want to bind the -- 'deprecatedContentCheck' splice to the content tag as a load time splice. defaultInterpretedSplices :: MonadIO m => Splices (I.Splice m) defaultInterpretedSplices = do applyTag ## applyImpl bindTag ## bindImpl ignoreTag ## ignoreImpl markdownTag ## markdownSplice allErrors :: [Either String (TPath, v)] -> EitherT [String] IO (HashMap TPath v) allErrors tlist = case errs of [] -> right $ Map.fromList $ rights tlist _ -> left errs where errs = lefts tlist ------------------------------------------------------------------------------ -- | Loads templates from disk. This function returns just a template map so -- you can load multiple directories and combine the maps before initializing -- your HeistState. loadTemplates :: FilePath -> EitherT [String] IO TemplateRepo loadTemplates dir = do d <- lift $ readDirectoryWith (loadTemplate dir) dir allErrors $ F.fold (free d) ------------------------------------------------------------------------------ -- | Reloads all the templates an an existing TemplateRepo. reloadTemplates :: TemplateRepo -> EitherT [String] IO TemplateRepo reloadTemplates repo = do tlist <- lift $ mapM loadOrKeep $ Map.toList repo allErrors tlist where loadOrKeep (p,df) = case dfFile df of Nothing -> return $ Right (p, df) Just fp -> do df' <- loadTemplate' fp return $ fmap (p,) $ case df' of [t] -> t _ -> Left "Template repo has non-templates" ------------------------------------------------------------------------------ -- | Adds a path prefix to a templates in a map returned by loadTemplates. If -- you want to add multiple levels of directories, separate them with slashes -- as in "foo/bar". Using an empty string as a path prefix will leave the -- map unchanged. addTemplatePathPrefix :: ByteString -> TemplateRepo -> TemplateRepo addTemplatePathPrefix dir ts | B.null dir = ts | otherwise = Map.fromList $ map (\(x,y) -> (f x, y)) $ Map.toList ts where f ps = ps++splitTemplatePath dir ------------------------------------------------------------------------------ -- | Creates an empty HeistState. emptyHS :: HE.KeyGen -> HeistState m emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty Map.empty True [] 0 [] Nothing kg False Html ------------------------------------------------------------------------------ -- | This is the main Heist initialization function. You pass in a map of all -- templates and all of your splices and it constructs and returns a -- HeistState. -- -- We don't provide functions to add either type of loadtime splices to your -- HeistState after initHeist because it doesn't make any sense unless you -- re-initialize all templates with the new splices. If you add any old-style -- runtime heist splices after calling this function, they will still work -- fine if you use Heist.Interpreted.renderTemplate. If you add any templates -- later, then those templates will be available for interpreted rendering, -- but not for compiled rendering. -- -- In the past you could add templates to your HeistState after initialization -- using its Monoid instance. Due to implementation details, this is no -- longer possible. All of your templates must be known when you call this -- function. initHeist :: Monad n => HeistConfig n -> EitherT [String] IO (HeistState n) initHeist hc = do keyGen <- lift HE.newKeyGen repos <- sequence $ hcTemplateLocations hc initHeist' keyGen hc (Map.unions repos) initHeist' :: Monad n => HE.KeyGen -> HeistConfig n -> TemplateRepo -> EitherT [String] IO (HeistState n) initHeist' keyGen (HeistConfig i lt c a _) repo = do let empty = emptyHS keyGen tmap <- preproc keyGen lt repo let hs1 = empty { _spliceMap = Map.fromList $ splicesToList i , _templateMap = tmap , _compiledSpliceMap = Map.fromList $ splicesToList c , _attrSpliceMap = Map.fromList $ splicesToList a } lift $ C.compileTemplates hs1 ------------------------------------------------------------------------------ -- | Runs preprocess on a TemplateRepo and returns the modified templates. preproc :: HE.KeyGen -> Splices (I.Splice IO) -> TemplateRepo -> EitherT [String] IO TemplateRepo preproc keyGen splices templates = do let hs = (emptyHS keyGen) { _spliceMap = Map.fromList $ splicesToList splices , _templateMap = templates , _preprocessingMode = True } let eval a = evalHeistT a (X.TextNode "") hs tPairs <- lift $ mapM (eval . preprocess) $ Map.toList templates let bad = lefts tPairs if not (null bad) then left bad else right $ Map.fromList $ rights tPairs ------------------------------------------------------------------------------ -- | Processes a single template, running load time splices. preprocess :: (TPath, DocumentFile) -> HeistT IO IO (Either String (TPath, DocumentFile)) preprocess (tpath, docFile) = do let tname = tpathName tpath !emdoc <- try $ I.evalWithDoctypes tname :: HeistT IO IO (Either SomeException (Maybe X.Document)) let f !doc = (tpath, docFile { dfDoc = doc }) return $! either (Left . show) (Right . maybe die f) emdoc where die = error "Preprocess didn't succeed! This should never happen." ------------------------------------------------------------------------------ -- | Wrapper around initHeist that also sets up a cache tag. It sets up both -- compiled and interpreted versions of the cache tag splices. If you need to -- configure the cache tag differently than how this function does it, you -- will still probably want to pattern your approach after this function's -- implementation. initHeistWithCacheTag :: MonadIO n => HeistConfig n -> EitherT [String] IO (HeistState n, CacheTagState) initHeistWithCacheTag (HeistConfig i lt c a locations) = do (ss, cts) <- liftIO mkCacheTag let tag = "cache" keyGen <- lift HE.newKeyGen repos <- sequence locations -- We have to do one preprocessing pass with the cache setup splice. This -- has to happen for both interpreted and compiled templates, so we do it -- here by itself because interpreted templates don't get the same load -- time splices as compiled templates. rawWithCache <- preproc keyGen (tag ## ss) $ Map.unions repos let hc' = HeistConfig (insertS tag (cacheImpl cts) i) lt (insertS tag (cacheImplCompiled cts) c) a locations hs <- initHeist' keyGen hc' rawWithCache return (hs, cts) heist-0.13.0.2/src/Data/0000755000000000000000000000000012226547635012711 5ustar0000000000000000heist-0.13.0.2/src/Data/HeterogeneousEnvironment.hs0000644000000000000000000000550712226547635020315 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ module Data.HeterogeneousEnvironment ( KeyGen , HeterogeneousEnvironment , Key , newKeyGen , empty , makeKey , lookup , insert , delete , adjust , getKeyId ) where ------------------------------------------------------------------------------ import Control.Monad import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.IORef import GHC.Exts import Prelude hiding (lookup) import Unsafe.Coerce ------------------------------------------------------------------------------ data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any) newtype Key a = Key Int newtype KeyGen = KeyGen (IORef Int) ------------------------------------------------------------------------------ -- | If you use two different KeyGens to work with the same map, you deserve -- what you get. newKeyGen :: IO KeyGen newKeyGen = liftM KeyGen $ newIORef 0 ------------------------------------------------------------------------------ getKeyId :: Key a -> Int getKeyId (Key x) = x ------------------------------------------------------------------------------ empty :: HeterogeneousEnvironment empty = HeterogeneousEnvironment $ IM.empty ------------------------------------------------------------------------------ makeKey :: KeyGen -> IO (Key a) makeKey (KeyGen gen) = do k <- atomicModifyIORef gen nextKey return $ Key k where nextKey !x = if x >= maxBound-1 then error "too many keys generated" else let !x' = x+1 in (x',x) ------------------------------------------------------------------------------ lookup :: Key a -> HeterogeneousEnvironment -> Maybe a lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m ------------------------------------------------------------------------------ insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ IM.insert k (unsafeCoerce v) m ------------------------------------------------------------------------------ delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ IM.delete k m ------------------------------------------------------------------------------ adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $ IM.adjust f' k m where f' = unsafeCoerce . f . unsafeCoerce heist-0.13.0.2/src/Heist/0000755000000000000000000000000012226547635013114 5ustar0000000000000000heist-0.13.0.2/src/Heist/Common.hs0000644000000000000000000002760112226547635014706 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Heist.Common where import Control.Applicative import Control.Exception (SomeException) import Control.Monad import qualified Control.Monad.CatchIO as C import qualified Data.Attoparsec.Text as AP import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.List import Data.Maybe import Data.Monoid import qualified Data.Text as T import System.FilePath import Heist.SpliceAPI import Heist.Types import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ -- | If Heist is running in fail fast mode, then this function will throw an -- exception with the second argument as the error message. Otherwise, the -- first argument will be executed to represent silent failure. -- -- This behavior allows us to fail quickly if an error crops up during -- load-time splice processing or degrade more gracefully if the error occurs -- while a user request is being processed. orError :: Monad m => HeistT n m b -> String -> HeistT n m b orError silent msg = do hs <- getHS if _preprocessingMode hs then error $ (maybe "" (++": ") $ _curTemplateFile hs) ++ msg else silent ------------------------------------------------------------------------------ -- | Function for showing a TPath. showTPath :: TPath -> String showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName tpathName :: TPath -> ByteString tpathName = BC.intercalate "/" . reverse ------------------------------------------------------------------------------ -- | Sets the current template file. setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n setCurTemplateFile Nothing ts = ts setCurTemplateFile fp ts = ts { _curTemplateFile = fp } ------------------------------------------------------------------------------ setCurContext :: TPath -> HeistState n -> HeistState n setCurContext tp ts = ts { _curContext = tp } ------------------------------------------------------------------------------ -- | Parser for attribute variable substitution. attParser :: AP.Parser [AttAST] attParser = liftM ($! []) (loop id) where append !dl !x = dl . (x:) loop !dl = go id where finish subDL = let !txt = T.concat $! subDL [] lit = Literal $! T.concat $! subDL [] in return $! if T.null txt then dl else append dl lit go !subDL = (gobbleText >>= go . append subDL) <|> (AP.endOfInput *> finish subDL) <|> (do idp <- identParser dl' <- finish subDL loop $! append dl' idp) gobbleText = AP.takeWhile1 (AP.notInClass "$") identParser = AP.char '$' *> (ident <|> return (Literal "$")) ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}") ------------------------------------------------------------------------------ -- | Converts a path into an array of the elements in reverse order. If the -- path is absolute, we need to remove the leading slash so the split doesn't -- leave @\"\"@ as the last element of the TPath. -- -- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial splitPathWith :: Char -> ByteString -> TPath splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path) where path = if BC.head p == s then BC.tail p else p ------------------------------------------------------------------------------ -- | Converts a path into an array of the elements in reverse order using the -- path separator of the local operating system. See 'splitPathWith' for more -- details. splitLocalPath :: ByteString -> TPath splitLocalPath = splitPathWith pathSeparator ------------------------------------------------------------------------------ -- | Converts a path into an array of the elements in reverse order using a -- forward slash (/) as the path separator. See 'splitPathWith' for more -- details. splitTemplatePath :: ByteString -> TPath splitTemplatePath = splitPathWith '/' ------------------------------------------------------------------------------ -- | Convenience function for looking up a template. lookupTemplate :: ByteString -> HeistState n -> (HeistState n -> HashMap TPath t) -> Maybe (t, TPath) lookupTemplate nameStr ts tm = f (tm ts) path name where (name:p) = case splitTemplatePath nameStr of [] -> [""] ps -> ps ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts path = p ++ ctx f = if '/' `BC.elem` nameStr then singleLookup else traversePath ------------------------------------------------------------------------------ -- | Returns 'True' if the given template can be found in the heist state. hasTemplate :: ByteString -> HeistState n -> Bool hasTemplate nameStr ts = isJust $ lookupTemplate nameStr ts _templateMap ------------------------------------------------------------------------------ -- | Does a single template lookup without cascading up. singleLookup :: (Eq a, Hashable a) => HashMap [a] t -> [a] -> a -> Maybe (t, [a]) singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm ------------------------------------------------------------------------------ -- | Searches for a template by looking in the full path then backing up into -- each of the parent directories until the template is found. traversePath :: (Eq a, Hashable a) => HashMap [a] t -> [a] -> a -> Maybe (t, [a]) traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm) traversePath tm path name = singleLookup tm path name `mplus` traversePath tm (tail path) name ------------------------------------------------------------------------------ -- | Maps a splice generating function over a list and concatenates the -- results. This function now has a more general type signature so it works -- with both compiled and interpreted splices. The old type signature was -- this: -- -- > mapSplices :: (Monad n) -- > => (a -> Splice n n) -- > -> [a] -- > -> Splice n n mapSplices :: (Monad m, Monoid b) => (a -> m b) -- ^ Splice generating function -> [a] -- ^ List of items to generate splices for -> m b -- ^ The result of all splices concatenated together. mapSplices f vs = liftM mconcat $ mapM f vs {-# INLINE mapSplices #-} ------------------------------------------------------------------------------ -- | Gets the current context getContext :: Monad m => HeistT n m TPath getContext = getsHS _curContext ------------------------------------------------------------------------------ -- | Gets the full path to the file holding the template currently being -- processed. Returns Nothing if the template is not associated with a file -- on disk or if there is no template being processed. getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath) getTemplateFilePath = getsHS _curTemplateFile ------------------------------------------------------------------------------ -- | Loads a template with the specified path and filename. The -- template is only loaded if it has a ".tpl" or ".xtpl" extension. loadTemplate :: String -- ^ path of the template root -> String -- ^ full file path (includes the template root) -> IO [Either String (TPath, DocumentFile)] --TemplateMap loadTemplate templateRoot fname = do c <- loadTemplate' fname return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c where -- tName is path relative to the template root directory isHTMLTemplate = ".tpl" `isSuffixOf` fname correction = if last templateRoot == '/' then 0 else 1 extLen = if isHTMLTemplate then 4 else 5 tName = drop ((length templateRoot)+correction) $ -- We're only dropping the template root, not the whole path take ((length fname) - extLen) fname ------------------------------------------------------------------------------ -- | Loads a template at the specified path, choosing the appropriate parser -- based on the file extension. The template is only loaded if it has a -- \".tpl\" or \".xtpl\" extension. Returns an empty list if the extension -- doesn't match. loadTemplate' :: String -> IO [Either String DocumentFile] loadTemplate' fullDiskPath | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath | otherwise = return [] where isHTMLTemplate = ".tpl" `isSuffixOf` fullDiskPath isXMLTemplate = ".xtpl" `isSuffixOf` fullDiskPath ------------------------------------------------------------------------------ -- | Type synonym for parsers. type ParserFun = String -> ByteString -> Either String X.Document ------------------------------------------------------------------------------ -- | Reads an HTML or XML template from disk. getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) getDocWith parser f = do bs <- C.catch (liftM Right $ B.readFile f) (\(e::SomeException) -> return $ Left $ show e) let eitherDoc = either Left (parser f) bs return $ either (\s -> Left $ f ++ " " ++ s) (\d -> Right $ DocumentFile d (Just f)) eitherDoc ------------------------------------------------------------------------------ -- | Reads an HTML template from disk. getDoc :: String -> IO (Either String DocumentFile) getDoc = getDocWith X.parseHTML ------------------------------------------------------------------------------ -- | Reads an XML template from disk. getXMLDoc :: String -> IO (Either String DocumentFile) getXMLDoc = getDocWith X.parseXML ------------------------------------------------------------------------------ -- | Sets the templateMap in a HeistState. setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n setTemplates m ts = ts { _templateMap = m } ------------------------------------------------------------------------------ -- | Adds a template to the heist state. insertTemplate :: TPath -> DocumentFile -> HeistState n -> HeistState n insertTemplate p t st = setTemplates (Map.insert p t (_templateMap st)) st ------------------------------------------------------------------------------ -- Gives the MIME type for a 'X.Document' mimeType :: X.Document -> MIMEType mimeType d = case d of (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e (X.XmlDocument e _ _) -> "text/xml;charset=" `BC.append` enc e where enc X.UTF8 = "utf-8" -- Should not include byte order designation for UTF-16 since -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3) enc X.UTF16BE = "utf-16" enc X.UTF16LE = "utf-16" ------------------------------------------------------------------------------ -- | Binds a set of new splice declarations within a 'HeistState'. bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind -> HeistState n -- ^ start state -> HeistState n bindAttributeSplices ss hs = hs { _attrSpliceMap = Map.union (Map.fromList $ splicesToList ss) (_attrSpliceMap hs) } ------------------------------------------------------------------------------ -- | Mappends a doctype to the state. addDoctype :: Monad m => [X.DocType] -> HeistT n m () addDoctype dt = do modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt }) heist-0.13.0.2/src/Heist/Compiled.hs0000644000000000000000000000315412226547635015207 0ustar0000000000000000{-| Compiled splices are similar to the original Heist (interpreted) splices, but without the high performance costs of traversing a DOM at runtime. Compiled splices do all of their DOM processing at load time. They are compiled to produce a runtime computation that generates a ByteString Builder. This preserves the ability to write splices that access runtime information from the HTTP request, database, etc. If you import both this module and "Heist.Interpreted" in the same file, then you will need to import them qualified. -} module Heist.Compiled ( -- * High level compiled splice API Splice , renderTemplate , codeGen , runChildren -- * Functions for manipulating lists of compiled splices , textSplice , nodeSplice , pureSplice , deferMany , deferMap , mayDeferMap , bindLater , withSplices , manyWithSplices , withLocalSplices -- * Constructing Chunks -- $yieldOverview , yieldPure , yieldRuntime , yieldRuntimeEffect , yieldPureText , yieldRuntimeText -- * Running nodes and splices , runNodeList , runNode , runAttributes , runAttributesRaw , callTemplate ) where import Heist.Compiled.Internal -- $yieldOverview -- The internals of the Chunk data type are deliberately not exported because -- we want to hide the underlying implementation as much as possible. The -- @yield...@ functions give you lower level construction of DLists of Chunks. -- -- Most of the time you will use these functions composed with return to -- generate a Splice. But we decided not to include the return in these -- functions to allow you to work with the DLists purely. heist-0.13.0.2/src/Heist/Interpreted.hs0000644000000000000000000000431712226547635015742 0ustar0000000000000000{-| This module defines the API for writing and working with interpreted splices. It exports some of the same symbols as "Heist.Compiled", so you will probably want to import it qualified. Interpreted splices can be thought of as a function @Node -> m [Node]@. Heist then substitutes the resulting list of nodes into your template in place of the input node. 'Splice' is implemented as a type synonym @type Splice m = HeistT m [Node]@, and 'HeistT' has a function 'getParamNode' that lets you get the input node. Suppose you have a place on your page where you want to display a link with the text \"Logout username\" if the user is currently logged in or a link to the login page if no user is logged in. Assume you have a function @getUser :: MyAppMonad (Maybe Text)@ that gets the current user. You can implement this functionality with a 'Splice' as follows: > import Blaze.ByteString.Builder > import Data.ByteString.Char8 (ByteString) > import qualified Data.ByteString.Char8 as B > import Data.Text (Text) > import qualified Data.Text as T > import qualified Text.XmlHtml as X > > import qualified Heist.Interpreted as I > > link :: Text -> Text -> X.Node > link target text = X.Element "a" [("href", target)] [X.TextNode text] > > loginLink :: X.Node > loginLink = link "/login" "Login" > > logoutLink :: Text -> X.Node > logoutLink user = link "/logout" (T.append "Logout " user) > > loginLogoutSplice :: I.Splice MyAppMonad > loginLogoutSplice = do > user <- lift getUser > return [maybe loginLink logoutLink user] > -} module Heist.Interpreted ( Splice -- * HeistState Functions , addTemplate , addXMLTemplate , lookupSplice , bindSplice , bindSplices , bindAttributeSplices -- * Functions for creating splices , textSplice , runChildren , runChildrenWith , runChildrenWithTrans , runChildrenWithTemplates , runChildrenWithText , mapSplices -- * HeistT functions , stopRecursion , runNode , runAttributes , runNodeList , evalTemplate , bindStrings , bindString , callTemplate , callTemplateWithText , renderTemplate , renderWithArgs ) where import Heist.Interpreted.Internal import Heist.Common (mapSplices, bindAttributeSplices) heist-0.13.0.2/src/Heist/SpliceAPI.hs0000644000000000000000000001373512226547635015232 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-| An API implementing a convenient syntax for defining and manipulating splices. This module was born from the observation that a list of tuples is semantically ambiguous about how duplicate keys should be handled. Additionally, the syntax is inherently rather cumbersome and difficult to work with. This API takes advantage of do notation to provide a very light syntax for defining splices while at the same time eliminating the semantic ambiguity of alists. Here's how you can define splices: > mySplices :: Splices Text > mySplices = do > "firstName" ## "John" > "lastName" ## "Smith" -} module Heist.SpliceAPI where import Control.Monad.State (State, MonadState, execState, modify) import Data.Map (Map) import qualified Data.Map as M import Data.Monoid import Data.Text (Text) import qualified Data.Text as T ------------------------------------------------------------------------------ -- | A monad providing convenient syntax for defining splices. newtype SplicesM s a = SplicesM { unSplices :: State (Map Text s) a } deriving (Monad, MonadState (Map Text s)) ------------------------------------------------------------------------------ -- | Monoid instance does a union of the two maps with the second map -- overwriting any duplicates. instance Monoid (Splices s) where mempty = noSplices mappend = unionWithS (\_ b -> b) ------------------------------------------------------------------------------ -- | Convenient type alias that will probably be used most of the time. type Splices s = SplicesM s () ------------------------------------------------------------------------------ -- | Forces a splice to be added. If the key already exists, its value is -- overwritten. (##) :: Text -> s -> Splices s (##) tag splice = modify $ M.insert tag splice infixr 0 ## ------------------------------------------------------------------------------ -- | Tries to add a splice, but if the key already exists, then it throws an -- error message. This may be useful if name collisions are bad and you want -- to crash when they occur. (#!) :: Text -> s -> Splices s (#!) tag splice = modify $ M.insertWithKey err tag splice where err k _ _ = error $ "Key "++show k++" already exists in the splice map" infixr 0 #! ------------------------------------------------------------------------------ -- | Inserts into the map only if the key does not already exist. (#?) :: Text -> s -> Splices s (#?) tag splice = modify $ M.insertWith (const id) tag splice infixr 0 #? ------------------------------------------------------------------------------ -- | A `Splices` with nothing in it. noSplices :: Splices s noSplices = return () ------------------------------------------------------------------------------ -- | Runs the SplicesM monad, generating a map of splices. runSplices :: SplicesM s a -> Map Text s runSplices splices = execState (unSplices splices) M.empty ------------------------------------------------------------------------------ -- | Constructs an alist representation. splicesToList :: SplicesM s a -> [(Text, s)] splicesToList = M.toList . runSplices ------------------------------------------------------------------------------ -- | Internal helper function for adding a map. add :: Map Text s -> Splices s add m = modify (\s -> M.unionWith (\_ b -> b) s m) ------------------------------------------------------------------------------ -- | Maps a function over all the splices. mapS :: (a -> b) -> Splices a -> Splices b mapS f ss = add $ M.map f $ runSplices ss ------------------------------------------------------------------------------ -- | Applies an argument to a splice function. applyS :: a -> Splices (a -> b) -> Splices b applyS a = mapS ($a) ------------------------------------------------------------------------------ -- | Inserts a splice into the 'Splices'. insertS :: Text -> s -> Splices s -> Splices s insertS = insertWithS const ------------------------------------------------------------------------------ -- | Inserts a splice with a function combining new value and old value. insertWithS :: (s -> s -> s) -> Text -> s -> SplicesM s a2 -> SplicesM s () insertWithS f k v b = add $ M.insertWith f k v (runSplices b) ------------------------------------------------------------------------------ -- | Union of `Splices` with a combining function. unionWithS :: (s -> s -> s) -> SplicesM s a1 -> SplicesM s a2 -> SplicesM s () unionWithS f a b = add $ M.unionWith f (runSplices a) (runSplices b) ------------------------------------------------------------------------------ -- | Infix operator for @flip applyS@ ($$) :: Splices (a -> b) -> a -> Splices b ($$) = flip applyS infixr 0 $$ ------------------------------------------------------------------------------ -- | Maps a function over all the splice names. mapNames :: (Text -> Text) -> Splices a -> Splices a mapNames f = add . M.mapKeys f . runSplices -- The following two functions are formulated as functions of Splices instead -- of a single splice because they operate on the splice names instead of the -- splices themselves. ------------------------------------------------------------------------------ -- | Adds a prefix to the tag names for a list of splices. If the existing -- tag name is empty, then the new tag name is just the prefix. Otherwise the -- new tag name is the prefix followed by the separator followed by the -- existing name. prefixSplices :: Text -> Text -> Splices a -> Splices a prefixSplices sep pre = mapNames f where f t = if T.null t then pre else T.concat [pre,sep,t] ------------------------------------------------------------------------------ -- | 'prefixSplices' specialized to use a colon as separator in the style of -- XML namespaces. namespaceSplices :: Text -> Splices a -> Splices a namespaceSplices = prefixSplices ":" heist-0.13.0.2/src/Heist/Splices.hs0000644000000000000000000000266112226547635015057 0ustar0000000000000000module Heist.Splices ( ifISplice , ifCSplice , module Heist.Splices.Apply , module Heist.Splices.Bind , module Heist.Splices.Cache , module Heist.Splices.Html , module Heist.Splices.Ignore , module Heist.Splices.Markdown ) where import Data.Monoid import qualified Heist.Compiled as C import qualified Heist.Interpreted as I import Heist.Splices.Apply import Heist.Splices.Bind import Heist.Splices.Cache import Heist.Splices.Html import Heist.Splices.Ignore import Heist.Splices.Markdown import Heist.Types ------------------------------------------------------------------------------ -- | Run the splice contents if given condition is True, make splice disappear -- if not. ifISplice :: Monad m => Bool -> I.Splice m ifISplice cond = case cond of False -> return [] True -> I.runChildren ------------------------------------------------------------------------------ -- | Function for constructing if splices that use a runtime predicate -- function to determine whether the node's children should be rendered. ifCSplice :: Monad m => (t -> Bool) -> RuntimeSplice m t -> C.Splice m ifCSplice predicate runtime = do chunks <- C.runChildren return $ C.yieldRuntime $ do a <- runtime if predicate a then C.codeGen chunks else return mempty heist-0.13.0.2/src/Heist/TemplateDirectory.hs0000644000000000000000000000660512226547635017117 0ustar0000000000000000{-| This module defines a TemplateDirectory data structure for convenient interaction with templates within web apps. -} module Heist.TemplateDirectory ( TemplateDirectory , newTemplateDirectory , newTemplateDirectory' , getDirectoryHS , getDirectoryCTS , reloadTemplateDirectory ) where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Error import Control.Monad import Control.Monad.Trans import Heist import Heist.Splices.Cache ------------------------------------------------------------------------------ -- | Structure representing a template directory. data TemplateDirectory n = TemplateDirectory FilePath (HeistConfig n) (MVar (HeistState n)) (MVar CacheTagState) ------------------------------------------------------------------------------ -- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for -- error handling. newTemplateDirectory :: MonadIO n => FilePath -> HeistConfig n -> EitherT [String] IO (TemplateDirectory n) newTemplateDirectory dir hc = do let hc' = hc { hcTemplateLocations = [loadTemplates dir] } (hs,cts) <- initHeistWithCacheTag hc' tsMVar <- liftIO $ newMVar hs ctsMVar <- liftIO $ newMVar cts return $ TemplateDirectory dir hc' tsMVar ctsMVar ------------------------------------------------------------------------------ -- | Creates and returns a new 'TemplateDirectory', using the monad's fail -- function on error. newTemplateDirectory' :: MonadIO n => FilePath -> HeistConfig n -> IO (TemplateDirectory n) newTemplateDirectory' dir hc = do res <- runEitherT $ newTemplateDirectory dir hc either (error . concat) return res ------------------------------------------------------------------------------ -- | Gets the 'HeistState' from a TemplateDirectory. getDirectoryHS :: (MonadIO n) => TemplateDirectory n -> IO (HeistState n) getDirectoryHS (TemplateDirectory _ _ tsMVar _) = liftIO $ readMVar $ tsMVar ------------------------------------------------------------------------------ -- | Clears the TemplateDirectory's cache tag state. getDirectoryCTS :: TemplateDirectory n -> IO CacheTagState getDirectoryCTS (TemplateDirectory _ _ _ ctsMVar) = readMVar ctsMVar ------------------------------------------------------------------------------ -- | Clears cached content and reloads templates from disk. reloadTemplateDirectory :: (MonadIO n) => TemplateDirectory n -> IO (Either String ()) reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do ehs <- runEitherT $ do initHeistWithCacheTag (hc { hcTemplateLocations = [loadTemplates p] }) leftPass ehs $ \(hs,cts) -> do modifyMVar_ tsMVar (const $ return hs) modifyMVar_ ctsMVar (const $ return cts) ------------------------------------------------------------------------------ -- | Prepends an error onto a Left. leftPass :: Monad m => Either [String] b -> (b -> m c) -> m (Either String c) leftPass e m = either (return . Left . loadError . concat) (liftM Right . m) e where loadError = (++) "Error loading templates: " heist-0.13.0.2/src/Heist/Types.hs0000644000000000000000000004311112226547635014554 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-| This module contains the core Heist data types. Edward Kmett wrote most of the HeistT monad code and associated instances, liberating us from the unused writer portion of RWST. -} module Heist.Types where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Applicative import Control.Arrow import Control.Monad.CatchIO (MonadCatchIO) import qualified Control.Monad.CatchIO as C import Control.Monad.Cont import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State.Strict import Data.ByteString.Char8 (ByteString) import Data.DList (DList) import qualified Data.HashMap.Strict as H import Data.HashMap.Strict (HashMap) import Data.HeterogeneousEnvironment (HeterogeneousEnvironment) import qualified Data.HeterogeneousEnvironment as HE import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding import Data.Typeable import qualified Text.XmlHtml as X import Debug.Trace tr :: Show a => String -> a -> a tr s x = trace (s++show x) x ------------------------------------------------------------------------------ -- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single -- root node\" constraint of well-formed XML because we want to allow -- templates to contain document fragments that may not have a single root. type Template = [X.Node] ------------------------------------------------------------------------------ -- | MIME Type. The type alias is here to make the API clearer. type MIMEType = ByteString ------------------------------------------------------------------------------ -- | Reversed list of directories. This holds the path to the template -- currently being processed. type TPath = [ByteString] ------------------------------------------------------------------------------ -- | Holds data about templates read from disk. data DocumentFile = DocumentFile { dfDoc :: X.Document , dfFile :: Maybe FilePath } deriving (Eq) ------------------------------------------------------------------------------ -- | Designates whether a document should be treated as XML or HTML. data Markup = Xml | Html ------------------------------------------------------------------------------ -- | Monad used for runtime splice execution. newtype RuntimeSplice m a = RuntimeSplice { unRT :: StateT HeterogeneousEnvironment m a } deriving ( Applicative , Functor , Monad , MonadIO , MonadState HeterogeneousEnvironment , MonadTrans ) ------------------------------------------------------------------------------ instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where mempty = return mempty a `mappend` b = do !x <- a !y <- b return $! x `mappend` y ------------------------------------------------------------------------------ -- | Opaque type representing pieces of output from compiled splices. data Chunk m = Pure !ByteString -- ^ output known at load time | RuntimeHtml !(RuntimeSplice m Builder) -- ^ output computed at run time | RuntimeAction !(RuntimeSplice m ()) -- ^ runtime action used only for its side-effect instance Show (Chunk m) where show (Pure _) = "Pure" show (RuntimeHtml _) = "RuntimeHtml" show (RuntimeAction _) = "RuntimeAction" showChunk :: Chunk m -> String showChunk (Pure b) = T.unpack $ decodeUtf8 b showChunk (RuntimeHtml _) = "RuntimeHtml" showChunk (RuntimeAction _) = "RuntimeAction" isPureChunk :: Chunk m -> Bool isPureChunk (Pure _) = True isPureChunk _ = False ------------------------------------------------------------------------------ -- | Type alias for attribute splices. The function parameter is the value of -- the bound attribute splice. The return value is a list of attribute -- key/value pairs that get substituted in the place of the bound attribute. type AttrSplice m = Text -> RuntimeSplice m [(Text, Text)] ------------------------------------------------------------------------------ -- | Holds all the state information needed for template processing. You will -- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState -> -- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@ -- in calls to 'renderTemplate'. -- -- m is the runtime monad data HeistState m = HeistState { -- | A mapping of splice names to splice actions _spliceMap :: HashMap Text (HeistT m m Template) -- | A mapping of template names to templates , _templateMap :: HashMap TPath DocumentFile -- | A mapping of splice names to splice actions , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m))) -- | A mapping of template names to templates --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType) , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType)) , _attrSpliceMap :: HashMap Text (AttrSplice m) -- | A flag to control splice recursion , _recurse :: Bool -- | The path to the template currently being processed. , _curContext :: TPath -- | A counter keeping track of the current recursion depth to prevent -- infinite loops. , _recursionDepth :: Int -- | The doctypes encountered during template processing. , _doctypes :: [X.DocType] -- | The full path to the current template's file on disk. , _curTemplateFile :: Maybe FilePath -- | A key generator used to produce new unique Promises. , _keygen :: HE.KeyGen -- | Flag indicating whether we're in preprocessing mode. During -- preprocessing, errors should stop execution and be reported. During -- template rendering, it's better to skip the errors and render the page. , _preprocessingMode :: Bool -- | This is needed because compiled templates are generated with a bunch -- of calls to renderFragment rather than a single call to render. , _curMarkup :: Markup } -- NOTE: We got rid of the Monoid instance because it is absolutely not safe -- to combine two compiledTemplateMaps. All compiled templates must be known -- at load time and processed in a single call to initHeist/loadTemplates or -- whatever we end up calling it.. instance (Typeable1 m) => Typeable (HeistState m) where typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())] ------------------------------------------------------------------------------ -- | HeistT is the monad transformer used for splice processing. HeistT -- intentionally does not expose any of its functionality via MonadState or -- MonadReader functions. We define passthrough instances for the most common -- types of monads. These instances allow the user to use HeistT in a monad -- stack without needing calls to `lift`. -- -- @n@ is the runtime monad (the parameter to HeistState). -- -- @m@ is the monad being run now. In this case, \"now\" is a variable -- concept. The type @HeistT n n@ means that \"now\" is runtime. The type -- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT -- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@ -- means runtime. newtype HeistT n m a = HeistT { runHeistT :: X.Node -> HeistState n -> m (a, HeistState n) } ------------------------------------------------------------------------------ -- | Gets the names of all the templates defined in a HeistState. templateNames :: HeistState m -> [TPath] templateNames ts = H.keys $ _templateMap ts ------------------------------------------------------------------------------ -- | Gets the names of all the templates defined in a HeistState. compiledTemplateNames :: HeistState m -> [TPath] compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts ------------------------------------------------------------------------------ -- | Gets the names of all the interpreted splices defined in a HeistState. spliceNames :: HeistState m -> [Text] spliceNames ts = H.keys $ _spliceMap ts ------------------------------------------------------------------------------ -- | Gets the names of all the compiled splices defined in a HeistState. compiledSpliceNames :: HeistState m -> [Text] compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts ------------------------------------------------------------------------------ -- | The Typeable instance is here so Heist can be dynamically executed with -- Hint. templateStateTyCon :: TyCon templateStateTyCon = mkTyCon "Heist.HeistState" {-# NOINLINE templateStateTyCon #-} ------------------------------------------------------------------------------ -- | Evaluates a template monad as a computation in the underlying monad. evalHeistT :: (Monad m) => HeistT n m a -> X.Node -> HeistState n -> m a evalHeistT m r s = do (a, _) <- runHeistT m r s return a {-# INLINE evalHeistT #-} ------------------------------------------------------------------------------ -- | Functor instance instance Functor m => Functor (HeistT n m) where fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s ------------------------------------------------------------------------------ -- | Applicative instance instance (Monad m, Functor m) => Applicative (HeistT n m) where pure = return (<*>) = ap ------------------------------------------------------------------------------ -- | Monad instance instance Monad m => Monad (HeistT n m) where return a = HeistT (\_ s -> return (a, s)) {-# INLINE return #-} HeistT m >>= k = HeistT $ \r s -> do (a, s') <- m r s runHeistT (k a) r s' {-# INLINE (>>=) #-} ------------------------------------------------------------------------------ -- | MonadIO instance instance MonadIO m => MonadIO (HeistT n m) where liftIO = lift . liftIO ------------------------------------------------------------------------------ -- | MonadTrans instance instance MonadTrans (HeistT n) where lift m = HeistT $ \_ s -> do a <- m return (a, s) ------------------------------------------------------------------------------ -- | MonadCatchIO instance instance MonadCatchIO m => MonadCatchIO (HeistT n m) where catch (HeistT a) h = HeistT $ \r s -> do let handler e = runHeistT (h e) r s C.catch (a r s) handler block (HeistT m) = HeistT $ \r s -> C.block (m r s) unblock (HeistT m) = HeistT $ \r s -> C.unblock (m r s) ------------------------------------------------------------------------------ -- | MonadFix passthrough instance instance MonadFix m => MonadFix (HeistT n m) where mfix f = HeistT $ \r s -> mfix $ \ (a, _) -> runHeistT (f a) r s ------------------------------------------------------------------------------ -- | Alternative passthrough instance instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where empty = mzero (<|>) = mplus ------------------------------------------------------------------------------ -- | MonadPlus passthrough instance instance MonadPlus m => MonadPlus (HeistT n m) where mzero = lift mzero m `mplus` n = HeistT $ \r s -> runHeistT m r s `mplus` runHeistT n r s ------------------------------------------------------------------------------ -- | MonadState passthrough instance instance MonadState s m => MonadState s (HeistT n m) where get = lift get {-# INLINE get #-} put = lift . put {-# INLINE put #-} ------------------------------------------------------------------------------ -- | MonadReader passthrough instance instance MonadReader r m => MonadReader r (HeistT n m) where ask = HeistT $ \_ s -> do r <- ask return (r,s) local f (HeistT m) = HeistT $ \r s -> local f (m r s) ------------------------------------------------------------------------------ -- | Helper for MonadError instance. liftCatch :: (m (a,HeistState n) -> (e -> m (a,HeistState n)) -> m (a,HeistState n)) -> HeistT n m a -> (e -> HeistT n m a) -> HeistT n m a liftCatch ce m h = HeistT $ \r s -> (runHeistT m r s `ce` (\e -> runHeistT (h e) r s)) ------------------------------------------------------------------------------ -- | MonadError passthrough instance instance (MonadError e m) => MonadError e (HeistT n m) where throwError = lift . throwError catchError = liftCatch catchError ------------------------------------------------------------------------------ -- | Helper for MonadCont instance. liftCallCC :: ((((a,HeistState n) -> m (b, HeistState n)) -> m (a, HeistState n)) -> m (a, HeistState n)) -> ((a -> HeistT n m b) -> HeistT n m a) -> HeistT n m a liftCallCC ccc f = HeistT $ \r s -> ccc $ \c -> runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s ------------------------------------------------------------------------------ -- | MonadCont passthrough instance instance (MonadCont m) => MonadCont (HeistT n m) where callCC = liftCallCC callCC ------------------------------------------------------------------------------ -- | The Typeable instance is here so Heist can be dynamically executed with -- Hint. templateMonadTyCon :: TyCon templateMonadTyCon = mkTyCon "Heist.HeistT" {-# NOINLINE templateMonadTyCon #-} instance (Typeable1 m) => Typeable1 (HeistT n m) where typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())] ------------------------------------------------------------------------------ -- Functions for our monad. ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Gets the node currently being processed. -- -- > -- > To sleep, perchance to dream. -- > -- -- When you call @getParamNode@ inside the code for the @speech@ splice, it -- returns the Node for the @speech@ tag and its children. @getParamNode >>= -- childNodes@ returns a list containing one 'TextNode' containing part of -- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would -- return @Just "Shakespeare"@. getParamNode :: Monad m => HeistT n m X.Node getParamNode = HeistT $ \r s -> return (r,s) {-# INLINE getParamNode #-} ------------------------------------------------------------------------------ -- | HeistT's 'local'. localParamNode :: Monad m => (X.Node -> X.Node) -> HeistT n m a -> HeistT n m a localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s {-# INLINE localParamNode #-} ------------------------------------------------------------------------------ -- | HeistT's 'gets'. getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r getsHS f = HeistT $ \_ s -> return (f s, s) {-# INLINE getsHS #-} ------------------------------------------------------------------------------ -- | HeistT's 'get'. getHS :: Monad m => HeistT n m (HeistState n) getHS = HeistT $ \_ s -> return (s, s) {-# INLINE getHS #-} ------------------------------------------------------------------------------ -- | HeistT's 'put'. putHS :: Monad m => HeistState n -> HeistT n m () putHS s = HeistT $ \_ _ -> return ((), s) {-# INLINE putHS #-} ------------------------------------------------------------------------------ -- | HeistT's 'modify'. modifyHS :: Monad m => (HeistState n -> HeistState n) -> HeistT n m () modifyHS f = HeistT $ \_ s -> return ((), f s) {-# INLINE modifyHS #-} ------------------------------------------------------------------------------ -- | Restores the HeistState. This function is almost like putHS except it -- preserves the current doctypes. You should use this function instead of -- @putHS@ to restore an old state. This was needed because doctypes needs to -- be in a "global scope" as opposed to the template call "local scope" of -- state items such as recursionDepth, curContext, and spliceMap. restoreHS :: Monad m => HeistState n -> HeistT n m () restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur }) {-# INLINE restoreHS #-} ------------------------------------------------------------------------------ -- | Abstracts the common pattern of running a HeistT computation with -- a modified heist state. localHS :: Monad m => (HeistState n -> HeistState n) -> HeistT n m a -> HeistT n m a localHS f k = do ts <- getHS putHS $ f ts res <- k restoreHS ts return res {-# INLINE localHS #-} ------------------------------------------------------------------------------ -- | Modifies the recursion depth. modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m () modRecursionDepth f = modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) }) ------------------------------------------------------------------------------ -- | AST to hold attribute parsing structure. This is necessary because -- attoparsec doesn't support parsers running in another monad. data AttAST = Literal Text | Ident Text deriving (Show) ------------------------------------------------------------------------------ isIdent :: AttAST -> Bool isIdent (Ident _) = True isIdent _ = False heist-0.13.0.2/src/Heist/Compiled/0000755000000000000000000000000012226547635014650 5ustar0000000000000000heist-0.13.0.2/src/Heist/Compiled/Internal.hs0000644000000000000000000006433612226547635016774 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} 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 ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | A compiled Splice is a HeistT computation that returns a @DList -- (Chunk m)@. -- -- The more interesting part of the type signature is what comes before the -- return value. The first type parameter in @'HeistT' n IO@ is the runtime -- monad. This reveals that the Chunks know about the runtime monad. The -- second type parameter in @HeistT n IO@ is @IO@. This tells is that the -- compiled splices themselves are run in the IO monad, which will usually -- mean at load time. Compiled splices run at load time, and they return -- computations that run at runtime. type Splice n = HeistT n IO (DList (Chunk n)) ------------------------------------------------------------------------------ -- | Runs the parameter node's children and returns the resulting compiled -- chunks. By itself this function is a simple passthrough splice that makes -- the spliced node disappear. In combination with locally bound splices, -- this function makes it easier to pass the desired view into your splices. runChildren :: Monad n => Splice n runChildren = runNodeList . X.childNodes =<< getParamNode {-# INLINE runChildren #-} renderFragment :: Markup -> [X.Node] -> Builder renderFragment markup ns = case markup of Html -> X.renderHtmlFragment X.UTF8 ns Xml -> X.renderXmlFragment X.UTF8 ns ------------------------------------------------------------------------------ -- | Yields pure text known at load time. pureTextChunk :: Text -> Chunk n pureTextChunk t = Pure $ T.encodeUtf8 t {-# INLINE pureTextChunk #-} ------------------------------------------------------------------------------ -- | Yields a pure Builder known at load time. You should use this and -- 'yieldPureText' as much as possible to maximize the parts of your page that -- can be compiled to static ByteStrings. yieldPure :: Builder -> DList (Chunk n) yieldPure = DL.singleton . Pure . toByteString {-# INLINE yieldPure #-} ------------------------------------------------------------------------------ -- | Yields a runtime action that returns a builder. yieldRuntime :: RuntimeSplice n Builder -> DList (Chunk n) yieldRuntime = DL.singleton . RuntimeHtml {-# INLINE yieldRuntime #-} ------------------------------------------------------------------------------ -- | Yields a runtime action that returns no value and is only needed for its -- side effect. yieldRuntimeEffect :: Monad n => RuntimeSplice n () -> DList (Chunk n) yieldRuntimeEffect = DL.singleton . RuntimeAction {-# INLINE yieldRuntimeEffect #-} ------------------------------------------------------------------------------ -- | A convenience wrapper around yieldPure for working with Text. Roughly -- equivalent to 'textSplice' from Heist.Interpreted. yieldPureText :: Text -> DList (Chunk n) yieldPureText = DL.singleton . pureTextChunk {-# INLINE yieldPureText #-} ------------------------------------------------------------------------------ -- | Convenience wrapper around yieldRuntime allowing you to work with Text. yieldRuntimeText :: Monad n => RuntimeSplice n Text -> DList (Chunk n) yieldRuntimeText = yieldRuntime . liftM fromText {-# INLINE yieldRuntimeText #-} ------------------------------------------------------------------------------ -- | Returns a computation that performs load-time splice processing on the -- supplied list of nodes. runNodeList :: Monad n => [X.Node] -> Splice n runNodeList = mapSplices runNode ------------------------------------------------------------------------------ -- | Runs a single splice and returns the builder computation. 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 ------------------------------------------------------------------------------ -- | Runs a DocumentFile with the appropriate template context set. 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 -- This gets overwritten in runDocumentFile nullNode = X.TextNode "" ------------------------------------------------------------------------------ compileTemplates :: Monad n => HeistState n -> IO (HeistState n) compileTemplates hs = do ctm <- compileTemplates' hs return $! hs { _compiledTemplateMap = ctm } -- let f = flip evalStateT HE.empty . unRT . codeGen -- return $! hs { _compiledTemplateMap = H.map (first f) 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 consecutive Pure Chunks. 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 ------------------------------------------------------------------------------ -- | Given a list of output chunks, consolidate turns consecutive runs of -- @Pure Html@ values into maximally-efficient pre-rendered strict -- 'ByteString' chunks. 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 {-# INLINE codeGen #-} ------------------------------------------------------------------------------ -- | Looks up a splice in the compiled splice map. lookupSplice :: Text -> HeistT n IO (Maybe (Splice n)) lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap) ------------------------------------------------------------------------------ -- | Runs a single node. If there is no splice referenced anywhere in the -- subtree, then it is rendered as a pure chunk, otherwise it calls -- compileNode to generate the appropriate runtime computation. 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, "}"] ------------------------------------------------------------------------------ -- | Checks whether a node's subtree is static and can be rendered up front at -- load time. 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 ------------------------------------------------------------------------------ -- | Checks whether a string has any attribute substitutions. 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 _ ) -> [] ------------------------------------------------------------------------------ -- | Given a 'X.Node' in the DOM tree, produces a \"runtime splice\" that will -- generate html at runtime. compileNode :: Monad n => X.Node -> Splice n compileNode (X.Element nm attrs ch) = -- Is this node a splice, or does it merely contain splices? lookupSplice nm >>= fromMaybe compileStaticElement where tag0 = T.append "<" nm end = T.concat [ ""] -- If the tag is not a splice, but it contains dynamic children compileStaticElement = do -- Parse the attributes: we have Left for static and Right for runtime 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 -- Handles inline parsing of $() splice syntax in attributes 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 -- Handles attribute splices 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 -- Handles inline parsing of $() splice syntax in attributes 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)] -- Handles attribute splices doAttrSplice splice = splice v ------------------------------------------------------------------------------ -- | Performs splice processing on a list of attributes. This is useful in -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. runAttributes :: Monad n => [(Text, Text)] -- ^ List of attributes -> HeistT n IO [DList (Chunk n)] runAttributes = mapM parseAtt ------------------------------------------------------------------------------ -- | Performs splice processing on a list of attributes. This is useful in -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. runAttributesRaw :: Monad n -- Note that this parameter should not be changed to Splices => [(Text, Text)] -- ^ List of attributes -> 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, "}"]) {-# INLINE getAttributeSplice #-} 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 {-# INLINE getAttributeSplice2 #-} ------------------------------------------------------------------------------ -- | Promises are used for referencing the results of future runtime -- computations during load time splice processing. newtype Promise a = Promise (HE.Key a) ------------------------------------------------------------------------------ -- | Gets the result of a promised runtime computation. 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) ++ ")" {-# INLINE getPromise #-} ------------------------------------------------------------------------------ -- | Adds a promise to the runtime splice context. putPromise :: (Monad n) => Promise a -> a -> RuntimeSplice n () putPromise (Promise k) x = modify (HE.insert k x) {-# INLINE putPromise #-} ------------------------------------------------------------------------------ -- | Modifies a promise. adjustPromise :: Monad n => Promise a -> (a -> a) -> RuntimeSplice n () adjustPromise (Promise k) f = modify (HE.adjust f k) {-# INLINE adjustPromise #-} ------------------------------------------------------------------------------ -- | Creates an empty promise. newEmptyPromise :: HeistT n IO (Promise a) newEmptyPromise = do keygen <- getsHS _keygen key <- liftIO $ HE.makeKey keygen return $! Promise key {-# INLINE newEmptyPromise #-} -- ------------------------------------------------------------------------------ -- -- | Creates an empty promise with some error checking to help with debugging. -- newEmptyPromiseWithError :: (Monad n) -- => String -> HeistT n IO (Promise a) -- newEmptyPromiseWithError from = do -- keygen <- getsHS _keygen -- prom <- liftM Promise $ liftIO $ HE.makeKey keygen -- yieldRuntimeEffect $ putPromise prom -- $ error -- $ "deferenced empty promise created at" ++ from -- return prom -- {-# INLINE newEmptyPromiseWithError #-} ------------------------------------------------------------------------------ -- | Binds a compiled splice. This function should not be exported. bindSplice :: Text -- ^ tag name -> Splice n -- ^ splice action -> HeistState n -- ^ source state -> HeistState n bindSplice n v ts = ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap ts) } ------------------------------------------------------------------------------ -- | Binds a list of compiled splices. This function should not be exported. bindSplices :: Splices (Splice n) -- ^ splices to bind -> HeistState n -- ^ source state -> HeistState n bindSplices ss ts = foldr (uncurry bindSplice) ts $ splicesToList ss ------------------------------------------------------------------------------ -- | Adds a list of compiled splices to the splice map. This function is -- useful because it allows compiled splices to bind other compiled splices -- during load-time splice processing. withLocalSplices :: Splices (Splice n) -> Splices (AttrSplice n) -> HeistT n IO a -> HeistT n IO a withLocalSplices ss as = localHS (bindSplices ss . bindAttributeSplices as) ------------------------------------------------------------------------------ -- | Looks up a compiled template and returns a runtime monad computation that -- constructs a builder. renderTemplate :: Monad n => HeistState n -> ByteString -> Maybe (n Builder, MIMEType) renderTemplate hs nm = fmap (first (interpret . DL.fromList) . fst) $! lookupTemplate nm hs _compiledTemplateMap ------------------------------------------------------------------------------ -- | Looks up a compiled template and returns a compiled splice. 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 ------------------------------------------------------------------------------ -- | Converts a pure text splice function to a pure Builder splice function. textSplice :: (a -> Text) -> a -> Builder textSplice f = fromText . f --------------- -- New Stuff -- --------------- ------------------------------------------------------------------------------ -- | Converts a pure Node splice function to a pure Builder splice function. nodeSplice :: (a -> [X.Node]) -> a -> Builder nodeSplice f = X.renderHtmlFragment X.UTF8 . f ------------------------------------------------------------------------------ -- | Converts a pure Builder splice function into a monadic splice function -- of a RuntimeSplice. pureSplice :: Monad n => (a -> Builder) -> RuntimeSplice n a -> Splice n pureSplice f n = return $ yieldRuntime (return . f =<< n) ------------------------------------------------------------------------------ -- | Runs a splice, but first binds splices given by splice functions that -- need some runtime data. withSplices :: Monad n => Splice n -- ^ Splice to be run -> Splices (RuntimeSplice n a -> Splice n) -- ^ Splices to be bound first -> RuntimeSplice n a -- ^ Runtime data needed by the above splices -> Splice n withSplices splice splices runtimeAction = withLocalSplices splices' noSplices splice where splices' = mapS ($runtimeAction) splices ------------------------------------------------------------------------------ -- | Like withSplices, but evaluates the splice repeatedly for each element in -- a list generated at runtime. 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 ------------------------------------------------------------------------------ -- | Similar to 'mapSplices' in interpreted mode. Gets a runtime list of -- items and applies a compiled runtime splice function to each element of the -- list. 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 ------------------------------------------------------------------------------ -- | Saves the results of a runtme computation in a 'Promise' so they don't -- get recalculated if used more than once. 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 ------------------------------------------------------------------------------ -- | Like deferMap, but only runs the result if a Maybe function of the -- runtime value returns Just. If it returns Nothing, then no output is -- generated. -- -- This is a good example of how to do more complex flow control with -- promises. The generalization of this abstraction is too complex to be -- distilled to elegant high-level combinators. If you need to implement your -- own special flow control, then you should use functions from the -- `Heist.Compiled.LowLevel` module similarly to how it is done in the -- implementation of this function. 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 ------------------------------------------------------------------------------ -- | Converts an RuntimeSplice into a Splice, given a helper function that -- generates a Builder. bindLater :: (Monad n) => (a -> RuntimeSplice n Builder) -> RuntimeSplice n a -> Splice n bindLater f p = return $ yieldRuntime $ f =<< p heist-0.13.0.2/src/Heist/Compiled/LowLevel.hs0000644000000000000000000000100212226547635016726 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module Heist.Compiled.LowLevel ( -- * Lower level promise functions Promise , newEmptyPromise , getPromise , putPromise , adjustPromise ) where import Heist.Compiled.Internal heist-0.13.0.2/src/Heist/Interpreted/0000755000000000000000000000000012226547635015401 5ustar0000000000000000heist-0.13.0.2/src/Heist/Interpreted/Internal.hs0000644000000000000000000004036712226547635017523 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Heist.Interpreted.Internal where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad import Control.Monad.State.Strict import qualified Data.Attoparsec.Text as AP import Data.ByteString (ByteString) import Data.List import qualified Data.HashMap.Strict as Map import qualified Data.HeterogeneousEnvironment as HE import Data.Maybe import qualified Data.Text as T import Data.Text (Text) import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import Heist.SpliceAPI import Heist.Types type Splice n = HeistT n n Template ------------------------------------------------------------------------------ -- HeistState functions ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Binds a new splice declaration to a tag name within a 'HeistState'. bindSplice :: Text -- ^ tag name -> Splice n -- ^ splice action -> HeistState n -- ^ source state -> HeistState n bindSplice n v hs = hs {_spliceMap = Map.insert n v (_spliceMap hs)} ------------------------------------------------------------------------------ -- | Binds a set of new splice declarations within a 'HeistState'. bindSplices :: Splices (Splice n) -- ^ splices to bind -> HeistState n -- ^ start state -> HeistState n bindSplices ss hs = foldl' (flip id) hs acts where acts = map (uncurry bindSplice) $ splicesToList ss ------------------------------------------------------------------------------ -- | Converts 'Text' to a splice returning a single 'TextNode'. textSplice :: Monad m => Text -> HeistT n m Template textSplice t = return [X.TextNode t] ------------------------------------------------------------------------------ -- | Runs the parameter node's children and returns the resulting node list. -- By itself this function is a simple passthrough splice that makes the -- spliced node disappear. In combination with locally bound splices, this -- function makes it easier to pass the desired view into your splices. runChildren :: Monad n => Splice n runChildren = runNodeList . X.childNodes =<< getParamNode ------------------------------------------------------------------------------ -- | Binds a list of splices before using the children of the spliced node as -- a view. runChildrenWith :: (Monad n) => Splices (Splice n) -- ^ List of splices to bind before running the param nodes. -> Splice n -- ^ Returns the passed in view. runChildrenWith splices = localHS (bindSplices splices) runChildren ------------------------------------------------------------------------------ -- | Wrapper around runChildrenWith that applies a transformation function to -- the second item in each of the tuples before calling runChildrenWith. runChildrenWithTrans :: (Monad n) => (b -> Splice n) -- ^ Splice generating function -> Splices b -- ^ List of tuples to be bound -> Splice n runChildrenWithTrans f = runChildrenWith . mapS f ------------------------------------------------------------------------------ -- | Like runChildrenWith but using constant templates rather than dynamic -- splices. runChildrenWithTemplates :: (Monad n) => Splices Template -> Splice n runChildrenWithTemplates = runChildrenWithTrans return ------------------------------------------------------------------------------ -- | Like runChildrenWith but using literal text rather than dynamic splices. runChildrenWithText :: (Monad n) => Splices Text -> Splice n runChildrenWithText = runChildrenWithTrans textSplice ------------------------------------------------------------------------------ -- | Convenience function for looking up a splice. lookupSplice :: Text -> HeistState n -> Maybe (Splice n) lookupSplice nm hs = Map.lookup nm $ _spliceMap hs {-# INLINE lookupSplice #-} ------------------------------------------------------------------------------ -- | Adds an HTML format template to the heist state. addTemplate :: ByteString -- ^ Path that the template will be referenced by -> Template -- ^ The template's DOM nodes -> Maybe FilePath -- ^ An optional path to the actual file on disk where the -- template is stored -> HeistState n -> HeistState n addTemplate n t mfp st = insertTemplate (splitTemplatePath n) doc st where doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp ------------------------------------------------------------------------------ -- | Adds an XML format template to the heist state. addXMLTemplate :: ByteString -- ^ Path that the template will be referenced by -> Template -- ^ The template's DOM nodes -> Maybe FilePath -- ^ An optional path to the actual file on disk where the -- template is stored -> HeistState n -> HeistState n addXMLTemplate n t mfp st = insertTemplate (splitTemplatePath n) doc st where doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp ------------------------------------------------------------------------------ -- | Stops the recursive processing of splices. Consider the following -- example: -- -- > -- > -- > ... -- > -- > -- -- Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@ -- splice will result in a list of nodes @L@. Normally @foo@ will recursively -- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@ -- will be included in the output verbatim without running any splices. stopRecursion :: Monad m => HeistT n m () stopRecursion = modifyHS (\st -> st { _recurse = False }) ------------------------------------------------------------------------------ -- | Performs splice processing on a single node. runNode :: Monad n => X.Node -> Splice n runNode (X.Element nm at ch) = do newAtts <- runAttributes at let n = X.Element nm newAtts ch s <- liftM (lookupSplice nm) getHS maybe (runKids newAtts) (recurseSplice n) s where runKids newAtts = do newKids <- runNodeList ch return [X.Element nm newAtts newKids] runNode n = return [n] ------------------------------------------------------------------------------ -- | Performs splice processing on a list of attributes. This is useful in -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. runAttributes :: Monad n => [(Text, Text)] -> HeistT n n [(Text, Text)] runAttributes attrs = (return . concat) =<< mapM runAttrSplice attrs ------------------------------------------------------------------------------ -- | Runs the attribute splice if it exists, otherwise it does inline $() -- substitution. runAttrSplice :: (Monad n) => (Text, Text) -> HeistT n n [(Text, Text)] runAttrSplice a@(k,v) = do splice <- getsHS (Map.lookup k . _attrSpliceMap) maybe (liftM (:[]) $ attSubst a) (lift . flip evalStateT HE.empty . unRT . ($v)) splice ------------------------------------------------------------------------------ -- | Helper function for substituting a parsed attribute into an attribute -- tuple. attSubst :: (Monad n) => (t, Text) -> HeistT n n (t, Text) attSubst (n,v) = do v' <- parseAtt v return (n,v') ------------------------------------------------------------------------------ -- | Parses an attribute for any identifier expressions and performs -- appropriate substitution. parseAtt :: (Monad n) => Text -> HeistT n n Text parseAtt bs = do let ast = case AP.feed (AP.parse attParser bs) "" of (AP.Done _ res) -> res (AP.Fail _ _ _) -> [] (AP.Partial _) -> [] chunks <- mapM cvt ast return $ T.concat chunks where cvt (Literal x) = return x cvt (Ident x) = localParamNode (const $ X.Element x [] []) $ getAttributeSplice x ------------------------------------------------------------------------------ -- | Gets the attribute value. If the splice's result list contains non-text -- nodes, this will translate them into text nodes with nodeText and -- concatenate them together. -- -- Originally, this only took the first node from the splices's result list, -- and only if it was a text node. This caused problems when the splice's -- result contained HTML entities, as they would split a text node. This was -- then fixed to take the first consecutive bunch of text nodes, and return -- their concatenation. This was seen as more useful than throwing an error, -- and more intuitive than trying to render all the nodes as text. -- -- However, it was decided in the end to render all the nodes as text, and -- then concatenate them. If a splice returned -- \"some \text\<\/b\> foobar\", the user would almost certainly want -- \"some text foobar\" to be rendered, and Heist would probably seem -- annoyingly limited for not being able to do this. If the user really did -- want it to render \"some \", it would probably be easier for them to -- accept that they were silly to pass more than that to be substituted than -- it would be for the former user to accept that -- \"some \text\<\/b\> foobar\" is being rendered as \"some \" because -- it's \"more intuitive\". getAttributeSplice :: Monad n => Text -> HeistT n n Text getAttributeSplice name = do hs <- getHS let noSplice = return $ T.concat ["${", name, "}"] s = lookupSplice name hs maybe noSplice (liftM (T.concat . map X.nodeText)) s ------------------------------------------------------------------------------ -- | Performs splice processing on a list of nodes. runNodeList :: Monad n => [X.Node] -> Splice n runNodeList = mapSplices runNode {-# INLINE runNodeList #-} ------------------------------------------------------------------------------ -- | The maximum recursion depth. (Used to prevent infinite loops.) mAX_RECURSION_DEPTH :: Int mAX_RECURSION_DEPTH = 50 ------------------------------------------------------------------------------ -- | Checks the recursion flag and recurses accordingly. Does not recurse -- deeper than mAX_RECURSION_DEPTH to avoid infinite loops. recurseSplice :: Monad n => X.Node -> Splice n -> Splice n recurseSplice node splice = do result <- localParamNode (const node) splice hs <- getHS if _recurse hs then if _recursionDepth hs < mAX_RECURSION_DEPTH then do modRecursionDepth (+1) res <- runNodeList result restoreHS hs return res else return result `orError` err else do modifyHS (\st -> st { _recurse = True }) return result where err = unwords ["Recursion limit reached in node" ,"<"++(T.unpack $ X.elementTag node)++">. You" ,"probably have infinite splice recursion!" ] ------------------------------------------------------------------------------ -- | Looks up a template name runs a 'HeistT' computation on it. lookupAndRun :: Monad m => ByteString -> ((DocumentFile, TPath) -> HeistT n m (Maybe a)) -> HeistT n m (Maybe a) lookupAndRun name k = do hs <- getHS let mt = lookupTemplate name hs _templateMap let curPath = join $ fmap (dfFile . fst) mt modifyHS (setCurTemplateFile curPath) maybe (return Nothing) k mt ------------------------------------------------------------------------------ -- | Looks up a template name evaluates it by calling runNodeList. evalTemplate :: Monad n => ByteString -> HeistT n n (Maybe Template) evalTemplate name = lookupAndRun name (\(t,ctx) -> localHS (\hs -> hs {_curContext = ctx}) (liftM Just $ runNodeList $ X.docContent $ dfDoc t)) ------------------------------------------------------------------------------ -- | Sets the document type of a 'X.Document' based on the 'HeistT' -- value. fixDocType :: Monad m => X.Document -> HeistT n m X.Document fixDocType d = do dts <- getsHS _doctypes return $ d { X.docType = listToMaybe dts } ------------------------------------------------------------------------------ -- | Runs a template and sets the doctype properly. This is the right thing -- to do if we are starting at the top level. evalWithDoctypes :: Monad n => ByteString -> HeistT n n (Maybe X.Document) evalWithDoctypes name = lookupAndRun name $ \(t,ctx) -> do addDoctype $ maybeToList $ X.docType $ dfDoc t hs <- getHS let nodes = X.docContent $ dfDoc t putHS (hs {_curContext = ctx}) newNodes <- runNodeList nodes restoreHS hs newDoc <- fixDocType $ (dfDoc t) { X.docContent = newNodes } return (Just newDoc) ------------------------------------------------------------------------------ -- | Binds a list of constant string splices. bindStrings :: Monad n => Splices Text -> HeistState n -> HeistState n bindStrings splices hs = foldr (uncurry bindString) hs $ splicesToList splices ------------------------------------------------------------------------------ -- | Binds a single constant string splice. bindString :: Monad n => Text -> Text -> HeistState n -> HeistState n bindString n = bindSplice n . textSplice ------------------------------------------------------------------------------ -- | Renders a template with the specified parameters. This is the function -- to use when you want to "call" a template and pass in parameters from -- inside a splice. If the template does not exist, this version simply -- returns an empty list. callTemplate :: Monad n => ByteString -- ^ The name of the template -> Splices (Splice n) -- ^ Splices to call the template with -> HeistT n n Template callTemplate name splices = do modifyHS $ bindSplices splices liftM (maybe [] id) $ evalTemplate name ------------------------------------------------------------------------------ -- | Like callTemplate except the splices being bound are constant text -- splices. callTemplateWithText :: Monad n => ByteString -- ^ The name of the template -> Splices Text -- ^ Splices to call the template with -> HeistT n n Template callTemplateWithText name splices = callTemplate name $ mapS textSplice splices ------------------------------------------------------------------------------ -- | Renders a template from the specified HeistState to a 'Builder'. The -- MIME type returned is based on the detected character encoding, and whether -- the root template was an HTML or XML format template. It will always be -- @text/html@ or @text/xml@. If a more specific MIME type is needed for a -- particular XML application, it must be provided by the application. renderTemplate :: Monad n => HeistState n -> ByteString -> n (Maybe (Builder, MIMEType)) renderTemplate hs name = evalHeistT tpl (X.TextNode "") hs where tpl = do mt <- evalWithDoctypes name case mt of Nothing -> return Nothing Just doc -> return $ Just $ (X.render doc, mimeType doc) ------------------------------------------------------------------------------ -- | Renders a template with the specified arguments passed to it. This is a -- convenience function for the common pattern of calling renderTemplate after -- using bindString, bindStrings, or bindSplice to set up the arguments to the -- template. renderWithArgs :: Monad n => Splices Text -> HeistState n -> ByteString -> n (Maybe (Builder, MIMEType)) renderWithArgs args hs = renderTemplate (bindStrings args hs) heist-0.13.0.2/src/Heist/Splices/0000755000000000000000000000000012226547635014516 5ustar0000000000000000heist-0.13.0.2/src/Heist/Splices/Apply.hs0000644000000000000000000000750412226547635016145 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Heist.Splices.Apply where ------------------------------------------------------------------------------ import Control.Monad.Trans import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import Heist.Interpreted.Internal import Heist.Types ------------------------------------------------------------------------------ -- | Default name for the apply splice. applyTag :: Text applyTag = "apply" ------------------------------------------------------------------------------ -- | Default attribute name for the apply tag. applyAttr :: Text applyAttr = "template" ------------------------------------------------------------------------------ -- | rawApply :: (Monad n) => Text -> [X.Node] -> Maybe FilePath -> TPath -> [X.Node] -> Splice n rawApply paramTag calledNodes templateFile newContext paramNodes = do hs <- getHS -- Can't use localHS here because the modifier is not pure processedParams <- runNodeList paramNodes -- apply should do a bottom-up traversal, so we run the called nodes -- before doing substitution. modifyHS (setCurContext newContext . setCurTemplateFile templateFile) let process = concatMap (treeMap processedParams) if _recursionDepth hs < mAX_RECURSION_DEPTH then do modRecursionDepth (+1) res <- runNodeList calledNodes restoreHS hs return $! process res else do restoreHS hs (return []) `orError` err where err = "template recursion exceeded max depth, "++ "you probably have infinite splice recursion!" treeMap :: [X.Node] -> X.Node -> [X.Node] treeMap ns n@(X.Element nm _ cs) | nm == paramTag = ns | otherwise = [n { X.elementChildren = cs' }] where !cs' = concatMap (treeMap ns) cs treeMap _ n = [n] ------------------------------------------------------------------------------ -- | Applies a template as if the supplied nodes were the children of the -- tag. applyNodes :: MonadIO n => Template -> Text -> Splice n applyNodes nodes template = do hs <- getHS maybe (return [] `orError` err) (\(t,ctx) -> do addDoctype $ maybeToList $ X.docType $ dfDoc t rawApply "apply-content" (X.docContent $ dfDoc t) (dfFile t) ctx nodes) (lookupTemplate (T.encodeUtf8 template) hs _templateMap) where err = "apply tag cannot find template \""++(T.unpack template)++"\"" ------------------------------------------------------------------------------ -- | Implementation of the apply splice. applyImpl :: MonadIO n => Splice n applyImpl = do node <- getParamNode let err = "must supply \"" ++ T.unpack applyAttr ++ "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" case X.getAttribute applyAttr node of Nothing -> return [] `orError` err Just template -> applyNodes (X.childNodes node) template ------------------------------------------------------------------------------ -- | This splice crashes with an error message. Its purpose is to provide a -- load-time warning to anyone still using the old content tag in their -- templates. In Heist 0.10, tho content tag was replaced by two separate -- apply-content and bind-content tags used by the apply and bind splices -- respectively. deprecatedContentCheck :: Monad m => Splice m deprecatedContentCheck = return [] `orError` unwords [" tag deprecated. Use" ," or " ] heist-0.13.0.2/src/Heist/Splices/Bind.hs0000644000000000000000000000251312226547635015727 0ustar0000000000000000module Heist.Splices.Bind where ------------------------------------------------------------------------------ import Control.Monad.Trans import Data.Text (Text) import qualified Data.Text as T import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import Heist.Interpreted.Internal import Heist.Splices.Apply import Heist.Types -- | Default name for the bind splice. bindTag :: Text bindTag = "bind" ------------------------------------------------------------------------------ -- | Default attribute name for the bind tag. bindAttr :: Text bindAttr = "tag" ------------------------------------------------------------------------------ -- | Implementation of the bind splice. bindImpl :: MonadIO n => Splice n bindImpl = do node <- getParamNode let err = "must supply \"" ++ T.unpack bindAttr ++ "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" maybe (return () `orError` err) (add node) (X.getAttribute bindAttr node) return [] where add node nm = modifyHS $ bindSplice nm $ do caller <- getParamNode ctx <- getContext rawApply "bind-content" (X.childNodes node) Nothing ctx (X.childNodes caller) heist-0.13.0.2/src/Heist/Splices/BindStrict.hs0000644000000000000000000000233612226547635017123 0ustar0000000000000000module Heist.Splices.BindStrict where ------------------------------------------------------------------------------ import Control.Monad.Trans import Data.Text (Text) import qualified Data.Text as T import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import Heist.Interpreted.Internal import Heist.Splices.Apply import Heist.Splices.Bind import Heist.Types -- | Default name for the bind splice. bindStrictTag :: Text bindStrictTag = "bindStrict" ------------------------------------------------------------------------------ -- | Implementation of the bind splice. bindStrictImpl :: MonadIO n => Splice n bindStrictImpl = do node <- getParamNode cs <- runChildren let err = "must supply \"" ++ T.unpack bindAttr ++ "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">" maybe (return () `orError` err) (add cs) (X.getAttribute bindAttr node) return [] where add cs nm = modifyHS $ bindSplice nm $ do caller <- getParamNode ctx <- getContext rawApply "bindstrict-content" cs Nothing ctx (X.childNodes caller) heist-0.13.0.2/src/Heist/Splices/Cache.hs0000644000000000000000000001625212226547635016063 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | The \"cache\" splice ensures that its contents are cached and only -- evaluated periodically. The cached contents are returned every time the -- splice is referenced. -- -- Use the ttl attribute to set the amount of time between reloads. The ttl -- value should be a positive integer followed by a single character -- specifying the units. Valid units are a single letter abbreviation for one -- of seconds, minutes, hours, days, and weeks. If the ttl string is invalid -- or the ttl attribute is not specified, the cache is never refreshed unless -- explicitly cleared with clearCacheTagState. The compiled splice version of -- the cache tag does not require a cache tag state, so clearCacheTagState -- will not work for compiled cache tags. module Heist.Splices.Cache ( CacheTagState , cacheImpl , cacheImplCompiled , mkCacheTag , clearCacheTagState ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Concurrent import Control.Monad import Control.Monad.Trans import Data.IORef import qualified Data.HashMap.Strict as H import Data.HashMap.Strict (HashMap) import qualified Data.HashSet as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Read import Data.Time.Clock import Data.Word import System.Random import Text.XmlHtml ------------------------------------------------------------------------------ import qualified Heist.Compiled.Internal as C import Heist.Interpreted.Internal import Heist.Types ------------------------------------------------------------------------------ cacheTagName :: Text cacheTagName = "cache" ------------------------------------------------------------------------------ -- | State for storing cache tag information newtype CacheTagState = CTS (MVar ([IORef (Maybe (UTCTime, Builder))], HashMap Text (UTCTime, Template))) addCompiledRef :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO () addCompiledRef ref (CTS mv) = do modifyMVar_ mv (\(a,b) -> return (ref:a, b)) ------------------------------------------------------------------------------ -- | Clears the cache tag state. clearCacheTagState :: CacheTagState -> IO () clearCacheTagState (CTS cacheMVar) = do refs <- modifyMVar cacheMVar (\(a,_) -> return ((a, H.empty), a)) mapM_ (\ref -> writeIORef ref Nothing) refs ------------------------------------------------------------------------------ -- | Converts a TTL string into an integer number of seconds. parseTTL :: Text -> Int parseTTL s = value * multiplier where (value,rest) = either (const (0::Int,"s")) id $ decimal s multiplier = case T.take 1 rest of "s" -> 1 :: Int "m" -> 60 "h" -> 3600 "d" -> 86400 "w" -> 604800 _ -> 1 getTTL :: Node -> NominalDiffTime getTTL tree = fromIntegral $ maybe 0 parseTTL $ getAttribute "ttl" tree {-# INLINE getTTL #-} ------------------------------------------------------------------------------ -- | This is the splice that actually does the work. You should bind it to -- the same tag name as you bound the splice returned by mkCacheTag otherwise -- it won't work and you'll get runtime errors. cacheImpl :: (MonadIO n) => CacheTagState -> Splice n cacheImpl (CTS mv) = do tree <- getParamNode let err = error $ unwords ["cacheImpl is bound to a tag" ,"that didn't get an id attribute." ," This should never happen."] let i = maybe err id $ getAttribute "id" tree !ttl = getTTL tree mp <- liftIO $ readMVar mv ns <- do cur <- liftIO getCurrentTime let mbn = H.lookup i $ snd mp reload = do nodes' <- runNodeList $ childNodes tree let newMap = H.insert i (cur, nodes') $ snd mp liftIO $ modifyMVar_ mv (\(a,_) -> return (a, newMap)) return $! nodes' case mbn of Nothing -> reload (Just (lastUpdate,n)) -> do if ttl > 0 && tagName tree == Just cacheTagName && diffUTCTime cur lastUpdate > ttl then reload else do stopRecursion return $! n return ns ------------------------------------------------------------------------------ -- | This is the compiled splice version of cacheImpl. cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n cacheImplCompiled cts = do tree <- getParamNode let !ttl = getTTL tree compiled <- C.runNodeList $ childNodes tree ref <- liftIO $ newIORef Nothing liftIO $ addCompiledRef ref cts let reload curTime = do builder <- C.codeGen compiled let out = fromByteString $! toByteString $! builder liftIO $ writeIORef ref (Just (curTime, out)) return $! out return $ C.yieldRuntime $ do mbn <- liftIO $ readIORef ref cur <- liftIO getCurrentTime case mbn of Nothing -> reload cur (Just (lastUpdate,bs)) -> do if (ttl > 0 && diffUTCTime cur lastUpdate > ttl) then reload cur else return $! bs ------------------------------------------------------------------------------ -- | Returns items necessary to set up a \"cache\" tag. The cache tag cannot -- be bound automatically with the other default Heist tags. This is because -- this function also returns CacheTagState, so the user will be able to clear -- it with the 'clearCacheTagState' function. -- -- This function returns a splice and a CacheTagState. The splice is of type -- @Splice IO@ because it has to be bound as a load time preprocessing splice. -- Haskell's type system won't allow you to screw up and pass this splice as -- the wrong argument to initHeist. mkCacheTag :: IO (Splice IO, CacheTagState) mkCacheTag = do sr <- newIORef $ Set.empty mv <- liftM CTS $ newMVar ([], H.empty) return $ (setupSplice sr, mv) ------------------------------------------------------------------------------ -- | Explicit type signature to avoid the Show polymorphism problem. generateId :: IO Word generateId = getStdRandom random ------------------------------------------------------------------------------ -- | Gets a unique ID for use in the cache tags. getId :: IORef (Set.HashSet Text) -> IO Text getId setref = do i <- liftM (T.pack . show) generateId _set <- readIORef setref if Set.member i _set then getId setref else do writeIORef setref $ Set.insert i _set return $ T.append "cache-id-" i ------------------------------------------------------------------------------ -- | A splice that sets the id attribute so that nodes can be cache-aware. setupSplice :: IORef (Set.HashSet Text) -> Splice IO setupSplice setref = do i <- liftIO $ getId setref node <- getParamNode newChildren <- runNodeList $ childNodes node stopRecursion return $ [setAttribute "id" i $ node { elementChildren = newChildren }] heist-0.13.0.2/src/Heist/Splices/Html.hs0000644000000000000000000000322312226547635015756 0ustar0000000000000000module Heist.Splices.Html where ------------------------------------------------------------------------------ import Data.Maybe import Data.Text (Text) import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Interpreted.Internal import Heist.Types ------------------------------------------------------------------------------ -- | Name for the html splice. htmlTag :: Text htmlTag = "html" ------------------------------------------------------------------------------ -- | The html splice runs all children and then traverses the returned node -- forest removing all head nodes. Then it merges them all and prepends it to -- the html tag's child list. htmlImpl :: Monad n => Splice n htmlImpl = do node <- getParamNode children <- runNodeList $ X.childNodes node let (heads, mnode) = extractHeads $ node { X.elementChildren = children } new (X.Element t a c) = X.Element t a $ X.Element "head" [] heads : c new n = n stopRecursion return [maybe node new mnode] ------------------------------------------------------------------------------ -- | Extracts all heads from a node tree. extractHeads :: X.Node -- ^ The root (html) node -> ([X.Node], Maybe X.Node) -- ^ A tuple of a list of head nodes and the original tree with -- heads removed. extractHeads (X.Element t a c) | t == "head" = (c, Nothing) | otherwise = (concat heads, Just $ X.Element t a (catMaybes mcs)) where (heads, mcs) = unzip $ map extractHeads c extractHeads n = ([], Just n) heist-0.13.0.2/src/Heist/Splices/Ignore.hs0000644000000000000000000000122312226547635016273 0ustar0000000000000000module Heist.Splices.Ignore where ------------------------------------------------------------------------------ import Data.Text (Text) ------------------------------------------------------------------------------ import Heist.Interpreted.Internal ------------------------------------------------------------------------------ -- | Default name for the ignore splice. ignoreTag :: Text ignoreTag = "ignore" ------------------------------------------------------------------------------ -- | The ignore tag and everything it surrounds disappears in the -- rendered output. ignoreImpl :: Monad m => Splice m ignoreImpl = return [] heist-0.13.0.2/src/Heist/Splices/Json.hs0000644000000000000000000002025612226547635015770 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Heist.Splices.Json ( bindJson ) where ------------------------------------------------------------------------------ import Control.Monad.Reader import Data.Aeson import Data.Attoparsec.Number import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as Map 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.Blaze.Html5 as B import Text.Blaze.Html5 ((!)) import Text.Blaze.Renderer.XmlHtml import Text.XmlHtml ------------------------------------------------------------------------------ import Heist.Interpreted.Internal import Heist.SpliceAPI import Heist.Types ------------ -- public -- ------------ ------------------------------------------------------------------------------ -- | This splice binds convenience tags for the given JSON (or -- JSON-convertible) value and runs the tag's child nodes using the new -- bindings. -- -- /Tags bound when you pass in an object/ -- -- Tags bound for an object looking like this: -- -- > { "k_1": v_1, ..., "k_N": v_N } -- -- @\@ -- treats v_i as text -- @\@ -- treats v_i as HTML -- @\@ -- explodes v_i and runs its children -- -- @\@ -- walks the JSON tree to find -- \"foo.bar.baz\", and interprets it as a string -- @\@ -- @\...\@ -- -- /Tags bound when you pass in anything else/ -- -- @\@ -- the given JSON value, as a string -- @\@ -- the given JSON value, parsed and spliced in as HTML -- bindJson :: (ToJSON a, Monad n) => a -> Splice n bindJson = runReaderT explodeTag . toJSON ------------- -- private -- ------------- ------------------------------------------------------------------------------ errorMessage :: String -> [Node] errorMessage s = renderHtmlNodes $ B.strong ! B.customAttribute "class" "error" $ B.toHtml s ------------------------------------------------------------------------------ type JsonMonad n m a = ReaderT Value (HeistT n m) a ------------------------------------------------------------------------------ withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a withValue = flip runReaderT ------------------------------------------------------------------------------ boolToText :: Bool -> Text boolToText b = if b then "true" else "false" ------------------------------------------------------------------------------ numToText :: Number -> Text numToText = T.decodeUtf8 . S.concat . L.toChunks . encode ------------------------------------------------------------------------------ findExpr :: Text -> Value -> Maybe Value findExpr t = go (T.split (=='.') t) where go [] !value = Just value go (x:xs) !value = findIn value >>= go xs where findIn (Object obj) = Map.lookup x obj findIn _ = Nothing ------------------------------------------------------------------------------ asHtml :: Monad m => Text -> m [Node] asHtml t = case (parseHTML "" $ T.encodeUtf8 t) of Left e -> return $ errorMessage $ "Template error turning JSON into HTML: " ++ e Right d -> return $! docContent d ------------------------------------------------------------------------------ snippetTag :: Monad m => JsonMonad n m [Node] snippetTag = ask >>= snip where txt t = lift $ asHtml t snip Null = txt "" snip (Bool b) = txt $ boolToText b snip (Number n) = txt $ numToText n snip (String t) = txt t snip _ = lift $ do node <- getParamNode return $ errorMessage $ concat [ "error processing tag <" , T.unpack $ fromMaybe "???" $ tagName node , ">: can't interpret JSON arrays or objects as HTML." ] ------------------------------------------------------------------------------ valueTag :: Monad m => JsonMonad n m [Node] valueTag = ask >>= go where go Null = txt "" go (Bool b) = txt $ boolToText b go (Number n) = txt $ numToText n go (String t) = txt t go _ = lift $ do node <- getParamNode return $ errorMessage $ concat [ "error processing tag <" , T.unpack $ fromMaybe "???" $ tagName node , ">: can't interpret JSON arrays or objects as text." ] txt t = return [TextNode t] ------------------------------------------------------------------------------ explodeTag :: (Monad n) => JsonMonad n n [Node] explodeTag = ask >>= go where -------------------------------------------------------------------------- go Null = goText "" go (Bool b) = goText $ boolToText b go (Number n) = goText $ numToText n go (String t) = goText t go (Array a) = goArray a go (Object o) = goObject o -------------------------------------------------------------------------- goText t = lift $ runChildrenWith $ do "value" ## return [TextNode t] "snippet" ## asHtml t -------------------------------------------------------------------------- goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node] goArray a = do lift stopRecursion dl <- V.foldM f id a return $! dl [] where f dl jsonValue = do tags <- go jsonValue return $! dl . (tags ++) -------------------------------------------------------------------------- -- search the param node for attribute \"var=expr\", search the given JSON -- object for the expression, and if it's found run the JsonMonad action m -- using the restricted JSON object. varAttrTag :: (Monad m) => Value -> (JsonMonad m m [Node]) -> Splice m varAttrTag v m = do node <- getParamNode maybe (noVar node) (hasVar node) $ getAttribute "var" node where noVar node = return $ errorMessage $ concat [ "expression error: no var attribute in <" , T.unpack $ fromMaybe "???" $ tagName node , "> tag" ] hasVar node expr = maybe (return $ errorMessage $ concat [ "expression error: can't find \"" , T.unpack expr , "\" in JSON object (<" , T.unpack $ fromMaybe "???" $ tagName node , "> tag)" ]) (runReaderT m) (findExpr expr v) -------------------------------------------------------------------------- genericBindings :: Monad n => JsonMonad n n (Splices (Splice n)) genericBindings = ask >>= \v -> return $ do "with" ## varAttrTag v explodeTag "snippet" ## varAttrTag v snippetTag "value" ## varAttrTag v valueTag -------------------------------------------------------------------------- goObject obj = do start <- genericBindings let bindings = Map.foldlWithKey' bindKvp start obj lift $ runChildrenWith bindings -------------------------------------------------------------------------- bindKvp bindings k v = let newBindings = do T.append "with:" k ## withValue v explodeTag T.append "snippet:" k ## withValue v snippetTag T.append "value:" k ## withValue v valueTag in unionWithS (\a _ -> a) newBindings bindings heist-0.13.0.2/src/Heist/Splices/Markdown.hs0000644000000000000000000001323312226547635016636 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-| The \"markdown\" splice formats markdown content as HTML and inserts it into the document. If the file attribute is present the contents of the tag is ignored and the file specified is converted to HTML. Otherwise the non-markup children of the tag are processed as markdown and converted to HTML. This splice requires that the \"pandoc\" executable is in your path. -} module Heist.Splices.Markdown where ------------------------------------------------------------------------------ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Maybe import Control.Concurrent import Control.Exception (throwIO) import Control.Monad import Control.Monad.CatchIO import Control.Monad.Trans import Data.Typeable import System.Directory import System.Exit import System.FilePath.Posix import System.IO import System.Process import Text.XmlHtml ------------------------------------------------------------------------------ import Heist.Common import Heist.Interpreted.Internal import Heist.Types data PandocMissingException = PandocMissingException deriving (Typeable) instance Show PandocMissingException where show PandocMissingException = "Cannot find the \"pandoc\" executable; is it on your $PATH?" instance Exception PandocMissingException data MarkdownException = MarkdownException ByteString deriving (Typeable) instance Show MarkdownException where show (MarkdownException e) = "Markdown error: pandoc replied:\n\n" ++ BC.unpack e instance Exception MarkdownException data NoMarkdownFileException = NoMarkdownFileException deriving (Typeable) instance Show NoMarkdownFileException where show NoMarkdownFileException = "Markdown error: no file or template in context" ++ " during processing of markdown tag" instance Exception NoMarkdownFileException where ------------------------------------------------------------------------------ -- | Default name for the markdown splice. markdownTag :: Text markdownTag = "markdown" ------------------------------------------------------------------------------ -- | Implementation of the markdown splice. markdownSplice :: MonadIO m => Splice m markdownSplice = do templateDir <- liftM (fmap takeDirectory) getTemplateFilePath pdMD <- liftIO $ findExecutable "pandoc" when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException tree <- getParamNode (source,markup) <- liftIO $ case getAttribute "file" tree of Just f -> do m <- maybe (liftIO $ throwIO NoMarkdownFileException ) (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f) templateDir return (T.unpack f,m) Nothing -> do m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree return ("inline_splice",m) let ee = parseHTML source markup case ee of Left e -> throw $ MarkdownException $ BC.pack ("Error parsing markdown output: " ++ e) Right d -> return (docContent d) pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString pandoc pandocPath templateDir inputFile = do (ex, sout, serr) <- readProcessWithExitCode' pandocPath args "" when (isFail ex) $ throw $ MarkdownException serr return $ BC.concat [ "
\n" , sout , "\n
" ] where isFail ExitSuccess = False isFail _ = True args = [ "-S", "--no-wrap", templateDir inputFile ] pandocBS :: FilePath -> ByteString -> IO ByteString pandocBS pandocPath s = do -- using the crummy string functions for convenience here (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s when (isFail ex) $ throw $ MarkdownException serr return $ BC.concat [ "
\n" , sout , "\n
" ] where isFail ExitSuccess = False isFail _ = True args = [ "-S", "--no-wrap" ] -- a version of readProcessWithExitCode that does I/O properly readProcessWithExitCode' :: FilePath -- ^ command to run -> [String] -- ^ any arguments -> ByteString -- ^ standard input -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr readProcessWithExitCode' cmd args input = do (Just inh, Just outh, Just errh, pid) <- createProcess (proc cmd args){ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } outMVar <- newEmptyMVar outM <- newEmptyMVar errM <- newEmptyMVar -- fork off a thread to start consuming stdout _ <- forkIO $ do out <- B.hGetContents outh putMVar outM out putMVar outMVar () -- fork off a thread to start consuming stderr _ <- forkIO $ do err <- B.hGetContents errh putMVar errM err putMVar outMVar () -- now write and flush any input when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh hClose inh -- done with stdin -- wait on the output takeMVar outMVar takeMVar outMVar hClose outh -- wait on the process ex <- waitForProcess pid out <- readMVar outM err <- readMVar errM return (ex, out, err) heist-0.13.0.2/test/0000755000000000000000000000000012226547635012230 5ustar0000000000000000heist-0.13.0.2/test/.ghci0000644000000000000000000000014312226547635013141 0ustar0000000000000000:set -XOverloadedStrings :set -Wall :set -i../src :set -isuite :set -hide-package MonadCatchIO-mtl heist-0.13.0.2/test/heist-testsuite.cabal0000644000000000000000000000730212226547635016361 0ustar0000000000000000name: heist-testsuite version: 0.1.1 build-type: Simple cabal-version: >= 1.6 Executable testsuite hs-source-dirs: ../src suite main-is: TestSuite.hs build-depends: HUnit >= 1.2 && < 2, QuickCheck >= 2, MonadCatchIO-transformers >= 0.2.1 && < 0.4, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, aeson >= 0.6 && < 0.7, attoparsec >= 0.10 && < 0.11, base >= 4 && < 5, blaze-builder >= 0.2 && < 0.4, blaze-html >= 0.4 && < 0.7, bytestring >= 0.9 && < 0.11, containers >= 0.2 && < 0.6, directory >= 1.1 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, errors >= 1.4 && < 1.5, filepath >= 1.3 && < 1.4, hashable >= 1.1 && < 1.3, mtl >= 2.0 && < 2.2, process >= 1.1 && < 1.2, random >= 1.0.1.0 && < 1.1, text >= 0.10 && < 0.12, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, xmlhtml >= 0.2.3 && < 0.3 ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded Extensions: OverloadedStrings Executable benchmark hs-source-dirs: ../src suite main-is: Benchmark.hs build-depends: MonadCatchIO-transformers >= 0.3 && < 0.4, HUnit >= 1.2 && < 1.3, criterion >= 0.6 && < 0.7, test-framework >= 0.4 && < 0.7, test-framework-hunit >= 0.2 && < 0.3, -- Copied from regular dependencies: aeson >= 0.6 && < 0.7, attoparsec >= 0.10 && < 0.11, base >= 4 && < 5, blaze-builder >= 0.2 && < 0.4, blaze-html >= 0.4 && < 0.7, bytestring >= 0.9 && < 0.11, containers >= 0.2 && < 0.6, directory >= 1.1 && < 1.3, directory-tree >= 0.10 && < 0.12, dlist >= 0.5 && < 0.6, errors >= 1.4 && < 1.5, filepath >= 1.3 && < 1.4, hashable >= 1.1 && < 1.3, mtl >= 2.0 && < 2.2, process >= 1.1 && < 1.2, random >= 1.0.1.0 && < 1.1, statistics < 0.10.4, text >= 0.10 && < 0.12, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, xmlhtml >= 0.2.3 && < 0.3 ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts ghc-prof-options: -prof -auto-all Extensions: GeneralizedNewtypeDeriving, PackageImports, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, TypeSynonymInstances, NoMonomorphismRestriction heist-0.13.0.2/test/README0000644000000000000000000000007112226547635013106 0ustar0000000000000000Various test applications and such for the Snap Frameworkheist-0.13.0.2/test/runTestsAndCoverage.sh0000755000000000000000000000127012226547635016515 0ustar0000000000000000#!/bin/sh set -e SUITE=./dist/build/testsuite/testsuite rm -f testsuite.tix if [ ! -f $SUITE ]; then cat </dev/null 2>&1 rm -f testsuite.tix cat < String -> IO () applyComparison dir pageStr = do let page = encodeUtf8 $ T.pack pageStr hs <- loadWithCache dir let compiledAction = do res <- fst $ fromJust $ C.renderTemplate hs page return $! toByteString $! res out <- compiledAction B.writeFile (pageStr++".out.compiled."++dir) $ out let interpretedAction = do res <- I.renderTemplate hs page return $! toByteString $! fst $! fromJust res out2 <- interpretedAction B.writeFile (pageStr++".out.interpreted."++dir) $ out defaultMain [ bench (pageStr++"-compiled") (whnfIO compiledAction) , bench (pageStr++"-interpreted") (whnfIO interpretedAction) ] cmdLineTemplate :: String -> String -> IO () cmdLineTemplate dir page = do -- args <- getArgs -- let page = head args -- let dir = "test/snap-website" hs <- loadHS dir let action = fst $ fromJust $ C.renderTemplate hs (encodeUtf8 $ T.pack page) out <- action B.writeFile (page++".out.cur") $ toByteString out -- reference <- B.readFile "faq.out" -- if False -- then do -- putStrLn "Template didn't render properly" -- error "Aborting" -- else -- putStrLn "Template rendered correctly" defaultMain [ bench (page++"-speed") action ] testNode = X.Element "div" [("foo", "aoeu"), ("bar", "euid")] [X.Element "b" [] [X.TextNode "bolded text"] ,X.TextNode " not bolded" ,X.Element "a" [("href", "/path/to/page")] [X.TextNode "link"] ] getChunks templateName = do hs <- loadHS "snap-website-nocache" let (Just t) = lookupTemplate templateName hs _compiledTemplateMap return $! fst $! fst t heist-0.13.0.2/test/suite/TestSuite.hs0000644000000000000000000000103312226547635015643 0ustar0000000000000000module Main where import Test.Framework (defaultMain, testGroup) import qualified Heist.Interpreted.Tests import qualified Heist.Compiled.Tests import qualified Heist.Tests main :: IO () main = defaultMain tests where tests = [ testGroup "Heist.Interpreted.Tests" Heist.Interpreted.Tests.tests , testGroup "Heist.Compiled.Tests" Heist.Compiled.Tests.tests , testGroup "Heist.Tests" Heist.Tests.tests ] heist-0.13.0.2/test/suite/Heist/0000755000000000000000000000000012226547635014435 5ustar0000000000000000heist-0.13.0.2/test/suite/Heist/TestCommon.hs0000644000000000000000000000726312226547635017071 0ustar0000000000000000module Heist.TestCommon where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Error import Control.Monad.Trans import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Maybe import Data.Monoid ------------------------------------------------------------------------------ import Heist import qualified Heist.Compiled as C import qualified Heist.Interpreted as I import qualified Heist.Interpreted.Internal as I import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ -- | The default doctype given to templates doctype :: ByteString doctype = B.concat [ "" ] loadT :: MonadIO m => FilePath -> Splices (I.Splice m) -> Splices (I.Splice IO) -> Splices (C.Splice m) -> Splices (AttrSplice m) -> IO (Either [String] (HeistState m)) loadT baseDir a b c d = runEitherT $ do let hc = HeistConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir] initHeist hc ------------------------------------------------------------------------------ loadIO :: FilePath -> Splices (I.Splice IO) -> Splices (I.Splice IO) -> Splices (C.Splice IO) -> Splices (AttrSplice IO) -> IO (Either [String] (HeistState IO)) loadIO baseDir a b c d = runEitherT $ do let hc = HeistConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir] initHeist hc ------------------------------------------------------------------------------ loadHS :: FilePath -> IO (HeistState IO) loadHS baseDir = do etm <- runEitherT $ do let hc = HeistConfig defaultInterpretedSplices defaultLoadTimeSplices mempty mempty [loadTemplates baseDir] initHeist hc either (error . concat) return etm loadEmpty :: Splices (I.Splice IO) -> Splices (I.Splice IO) -> Splices (C.Splice IO) -> Splices (AttrSplice IO) -> IO (HeistState IO) loadEmpty a b c d = do let hc = HeistConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d mempty res <- runEitherT $ initHeist hc either (error . concat) return res testTemplate :: FilePath -> ByteString -> IO ByteString testTemplate tdir tname = do ts <- loadHS tdir Just (resDoc, _) <- I.renderTemplate ts tname return $ toByteString resDoc testTemplateEval :: ByteString -> IO (Maybe Template) testTemplateEval tname = do ts <- loadHS "templates" md <- evalHeistT (I.evalWithDoctypes tname) (X.TextNode "") ts return $ fmap X.docContent md ------------------------------------------------------------------------------ -- | Reloads the templates from disk and renders the specified -- template. (Old convenience code.) quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) quickRender baseDir name = do ts <- loadHS baseDir res <- I.renderTemplate ts name return (fmap (toByteString . fst) res) cRender :: HeistState IO -> ByteString -> IO ByteString cRender hs name = do builder <- fst $ fromJust $ C.renderTemplate hs name return $ toByteString builder iRender :: HeistState IO -> ByteString -> IO ByteString iRender hs name = do builder <- I.renderTemplate hs name return $ toByteString $ fst $ fromJust builder heist-0.13.0.2/test/suite/Heist/Tests.hs0000644000000000000000000001625612226547635016105 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Heist.Tests ( tests ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad.State import qualified Data.ByteString.Char8 as B import Data.List import Data.Maybe import Data.Monoid import qualified Data.Text as T import Test.Framework (Test) import Test.Framework.Providers.HUnit import qualified Test.HUnit as H ------------------------------------------------------------------------------ import Heist import qualified Heist.Compiled as C import Heist.Tutorial.AttributeSplices import Heist.Tutorial.CompiledSplices import qualified Heist.Interpreted as I import Heist.Splices.Cache import Heist.Splices.Html import Heist.TemplateDirectory import Heist.TestCommon tests :: [Test] tests = [ testCase "loadErrors" loadErrorsTest , testCase "attrsplice/autocheck" attrSpliceTest , testCase "tdirCache" tdirCacheTest , testCase "headMerge" headMergeTest , testCase "bindApplyInteraction" bindApplyInteractionTest , testCase "backslashHandling" backslashHandlingTest ] ------------------------------------------------------------------------------ -- | Tests that load fails correctly on errors. loadErrorsTest :: H.Assertion loadErrorsTest = do ets <- loadIO "templates-bad" mempty mempty mempty mempty either (H.assertEqual "load errors test" expected . sort) (const $ H.assertFailure "No failure when loading templates-bad") ets where expected = sort ["templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!" ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"" ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in " ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in " ] attrSpliceTest :: IO () attrSpliceTest = do ehs <- loadT "templates" mempty mempty mempty ("autocheck" ## lift . autocheckedSplice) let hs = either (error . show) id ehs runtime = fromJust $ C.renderTemplate hs "attr_splice" mres <- evalStateT (I.renderTemplate hs "attr_splice") "foo" H.assertEqual "interpreted foo" expected1 (toByteString $ fst $ fromJust mres) mres2 <- evalStateT (I.renderTemplate hs "attr_splice") "bar" H.assertEqual "interpreted bar" expected2 (toByteString $ fst $ fromJust mres2) builder <- evalStateT (fst runtime) "foo" H.assertEqual "compiled foo" expected3 (toByteString builder) builder2 <- evalStateT (fst runtime) "bar" H.assertEqual "compiled bar" expected4 (toByteString builder2) where expected1 = "\n\n" expected2 = "\n\n" expected3 = " " expected4 = " " fooSplice :: I.Splice (StateT Int IO) fooSplice = do val <- get put val I.textSplice $ T.pack $ show val tdirCacheTest :: IO () tdirCacheTest = do let rSplices = ("foosplice" ## fooSplice) dSplices = ("foosplice" ## stateSplice) hc = HeistConfig rSplices mempty dSplices mempty mempty td <- newTemplateDirectory' "templates" hc [a,b,c,d] <- evalStateT (testInterpreted td) 5 H.assertBool "interpreted doesn't cache" $ a == b H.assertBool "interpreted doesn't clear" $ b /= c H.assertBool "interpreted doesn't reload" $ c /= d td' <- newTemplateDirectory' "templates" hc [e,f,g,h] <- evalStateT (testCompiled td') 5 H.assertBool "compiled doesn't cache" $ e == f H.assertBool "compiled doesn't clear" $ f /= g H.assertBool "compiled doesn't reload" $ g /= h where testInterpreted td = do hs <- liftIO $ getDirectoryHS td cts <- liftIO $ getDirectoryCTS td a <- I.renderTemplate hs "cache" modify (+1) b <- I.renderTemplate hs "cache" liftIO $ clearCacheTagState cts c <- I.renderTemplate hs "cache" modify (+1) _ <- liftIO $ reloadTemplateDirectory td -- The reload changes the HeistState, so we have to get it again hs' <- liftIO $ getDirectoryHS td d <- I.renderTemplate hs' "cache" return $ map (toByteString . fst . fromJust) [a,b,c,d] testCompiled td = do hs <- liftIO $ getDirectoryHS td cts <- liftIO $ getDirectoryCTS td a <- fst $ fromJust $ C.renderTemplate hs "cache" modify (+1) b <- fst $ fromJust $ C.renderTemplate hs "cache" liftIO $ clearCacheTagState cts c <- fst $ fromJust $ C.renderTemplate hs "cache" modify (+1) _ <- liftIO $ reloadTemplateDirectory td -- The reload changes the HeistState, so we have to get it again hs' <- liftIO $ getDirectoryHS td d <- fst $ fromJust $ C.renderTemplate hs' "cache" return $ map toByteString [a,b,c,d] headMergeTest :: IO () headMergeTest = do ehs <- loadT "templates" mempty (htmlTag ## htmlImpl) mempty mempty let hs = either (error . show) id ehs runtime = fromJust $ C.renderTemplate hs "head_merge/index" mres <- fst runtime H.assertEqual "assertion failed" expected (toByteString mres) where expected = B.intercalate "\n" ["\n\n" ,"\n\n" ,"\n\n\n\n
nav bar
\n\n\n" ,"
index page
\n\n\n " ] bindApplyInteractionTest :: IO () bindApplyInteractionTest = do hs <- loadHS "templates" cOut <- cRender hs "bind-apply-interaction/caller" H.assertEqual "compiled failure" cExpected cOut iOut <- iRender hs "bind-apply-interaction/caller" H.assertEqual "interpreted failure" iExpected iOut where cExpected = B.intercalate "\n" [" This is a test." ,"===bind content=== Another test line." ,"apply content Last test line." ," " ] iExpected = B.unlines [" This is a test." ,"===bind content===" ,"Another test line." ,"apply content" ,"Last test line." ,"" ] ------------------------------------------------------------------------------ -- | Test backslash escaping in the attribute parser. backslashHandlingTest :: IO () backslashHandlingTest = do hs <- loadHS "templates" cOut <- cRender hs "backslash" H.assertEqual "compiled failure" cExpected cOut iOut <- iRender hs "backslash" H.assertEqual "interpreted failure" iExpected iOut where cExpected = " " iExpected = "\n" heist-0.13.0.2/test/suite/Heist/Compiled/0000755000000000000000000000000012226547635016171 5ustar0000000000000000heist-0.13.0.2/test/suite/Heist/Compiled/Tests.hs0000644000000000000000000000251312226547635017630 0ustar0000000000000000module Heist.Compiled.Tests ( tests ) where import Test.Framework (Test) import Test.Framework.Providers.HUnit import qualified Test.HUnit as H ------------------------------------------------------------------------------ import Heist.Tutorial.CompiledSplices import Heist.TestCommon -- NOTE: We can't test compiled templates on the templates directory as it -- stands today because that directory contains some error conditions such as -- infinite bind loops, apply tags with no template attribute, and apply tags -- with ".." in the tag path (which doesn't currently work). tests :: [Test] tests = [ testCase "compiled/simple" simpleCompiledTest , testCase "compiled/people" peopleTest ] simpleCompiledTest :: IO () simpleCompiledTest = do res <- runWithStateSplice "templates" H.assertEqual "compiled state splice" expected res where expected = "\n 3 " peopleTest :: IO () peopleTest = do res <- personListTest "templates" H.assertEqual "people splice" expected res where expected = "

Doe, John: 42 years old

Smith, Jane: 21 years old

" heist-0.13.0.2/test/suite/Heist/Interpreted/0000755000000000000000000000000012226547635016722 5ustar0000000000000000heist-0.13.0.2/test/suite/Heist/Interpreted/Tests.hs0000644000000000000000000005411012226547635020361 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Heist.Interpreted.Tests ( tests , quickRender ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Error import Control.Monad.State import Data.Aeson import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text (Text) import System.IO.Unsafe import Test.Framework (Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import qualified Test.HUnit as H import Test.QuickCheck import Test.QuickCheck.Monadic ------------------------------------------------------------------------------ import Heist import Heist.Common import Heist.Interpreted.Internal import Heist.Splices.Apply import Heist.Splices.Ignore import Heist.Splices.Json import Heist.Splices.Markdown import Heist.TestCommon import Heist.Types import qualified Text.XmlHtml as X import qualified Text.XmlHtml.Cursor as X ------------------------------------------------------------------------------ tests :: [Test] tests = [ testProperty "heist/simpleBind" simpleBindTest , testProperty "heist/simpleApply" simpleApplyTest , testCase "heist/templateAdd" addTest , testCase "heist/hasTemplate" hasTemplateTest , testCase "heist/getDoc" getDocTest , testCase "heist/load" loadTest , testCase "heist/fsLoad" fsLoadTest , testCase "heist/renderNoName" renderNoNameTest , testCase "heist/doctype" doctypeTest , testCase "heist/attributeSubstitution" attrSubstTest , testCase "heist/bindAttribute" bindAttrTest , testCase "heist/markdown" markdownTest , testCase "heist/title_expansion" titleExpansion , testCase "heist/textarea_expansion" textareaExpansion , testCase "heist/div_expansion" divExpansion , testCase "heist/bind_param" bindParam , testCase "heist/markdownText" markdownTextTest , testCase "heist/apply" applyTest , testCase "heist/ignore" ignoreTest , testCase "heist/lookupTemplateContext" lookupTemplateTest , testCase "heist/attrSpliceContext" attrSpliceContext , testCase "heist/json/values" jsonValueTest , testCase "heist/json/object" jsonObjectTest , testCase "heist/renderXML" xmlNotHtmlTest ] ------------------------------------------------------------------------------ simpleBindTest :: Property simpleBindTest = monadicIO $ forAllM arbitrary prop where prop :: Bind -> PropertyM IO () prop bind = do let template = buildBindTemplate bind let result = buildResult bind spliceResult <- run $ do hs <- loadEmpty defaultLoadTimeSplices mempty mempty mempty evalHeistT (runNodeList template) (X.TextNode "") hs assert $ result == spliceResult ------------------------------------------------------------------------------ simpleApplyTest :: Property simpleApplyTest = monadicIO $ forAllM arbitrary prop where prop :: Apply -> PropertyM IO () prop apply = do let correct = calcCorrect apply result <- run $ calcResult apply assert $ correct == result ------------------------------------------------------------------------------ addTest :: IO () addTest = do es <- loadEmpty mempty mempty mempty mempty let hs = addTemplate "aoeu" [] Nothing es H.assertEqual "lookup test" (Just []) $ fmap (X.docContent . dfDoc . fst) $ lookupTemplate "aoeu" hs _templateMap ------------------------------------------------------------------------------ hasTemplateTest :: H.Assertion hasTemplateTest = do ets <- loadIO "templates" mempty mempty mempty mempty let tm = either (error "Error loading templates") _templateMap ets hs <- loadEmpty mempty mempty mempty mempty let hs's = setTemplates tm hs H.assertBool "hasTemplate hs's" (hasTemplate "index" hs's) ------------------------------------------------------------------------------ getDocTest :: H.Assertion getDocTest = do d <- getDoc "bkteoar" H.assertBool "non-existent doc" $ isLeft d f <- getDoc "templates/index.tpl" H.assertBool "index doc" $ not $ isLeft f ------------------------------------------------------------------------------ loadTest :: H.Assertion loadTest = do ets <- loadIO "templates" mempty mempty mempty mempty either (error "Error loading templates") (\ts -> do let tm = _templateMap ts H.assertEqual "loadTest size" 37 $ Map.size tm ) ets ------------------------------------------------------------------------------ fsLoadTest :: H.Assertion fsLoadTest = do ets <- loadIO "templates" mempty mempty mempty mempty let tm = either (error "Error loading templates") _templateMap ets es <- loadEmpty mempty mempty mempty mempty let hs = setTemplates tm es let f = g hs f isNothing "abc/def/xyz" f isJust "a" f isJust "bar/a" f isJust "/bar/a" where g ts p n = H.assertBool ("loading template " ++ n) $ p $ lookupTemplate (B.pack n) ts _templateMap ------------------------------------------------------------------------------ renderNoNameTest :: H.Assertion renderNoNameTest = do ets <- loadT "templates" mempty mempty mempty mempty either (error "Error loading templates") (\ts -> do t <- renderTemplate ts "" H.assertBool "renderNoName" $ isNothing t ) ets ------------------------------------------------------------------------------ doctypeTest :: H.Assertion doctypeTest = do ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets Just (indexDoc, _) <- renderTemplate ts "index" H.assertEqual "index doctype test" indexRes $ toByteString $ indexDoc Just (_, _) <- renderTemplate ts "ioc" H.assertEqual "ioc doctype test" indexRes $ toByteString $ indexDoc where indexRes = B.concat [doctype ,"\n \n
\n/index\n
\n\n" ] ------------------------------------------------------------------------------ attrSubstTest :: H.Assertion attrSubstTest = do ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check "attr subst 1" (bindSplices splices ts) out1 check "attr subst 2" ts out2 where splices = defaultLoadTimeSplices `mappend` ("foo" ## return [X.TextNode "meaning_of_everything"]) check str ts expected = do Just (resDoc, _) <- renderTemplate ts "attrs" H.assertEqual str expected $ toByteString $ resDoc out1 = B.unlines ["Empty attribute" ,"No ident capture" ,"
" ] out2 = B.unlines ["Empty attribute" ,"No ident capture" ,"
" ] ------------------------------------------------------------------------------ bindAttrTest :: H.Assertion bindAttrTest = do ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check ts "
<b>ok</b>1" , "falsefoo" ] jsonExpected2 = "ok1falsefoo" ------------------------------------------------------------------------------ jsonObjectTest :: H.Assertion jsonObjectTest = do renderTest "json_object" jsonExpected where jsonExpected = "1ok12quuxquux1ok" ------------------------------------------------------------------------------ -- | Render a template and assert that it matches an expected result renderTest :: ByteString -- ^ template name -> ByteString -- ^ expected result -> H.Assertion renderTest templateName expectedResult = do ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check ts expectedResult where bind txt = bindJson v where v :: Value v = fromJust $ decode txt check ts0 str = do let splices = do "json" ## bind "[\"ok\", 1, null, false, \"foo\"]" "jsonObject" ## (bind $ mconcat [ "{\"foo\": 1, \"bar\": \"ok\", " , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, " , "\"quux\": \"quux\" }" ]) let ts = bindSplices splices ts0 Just (doc, _) <- renderTemplate ts templateName let result = B.filter (/= '\n') (toByteString doc) H.assertEqual ("Should match " ++ (show str)) str result ------------------------------------------------------------------------------ -- | Expansion of a bound name inside a title-tag titleExpansion :: H.Assertion titleExpansion = renderTest "title_expansion" expected where expected = "foo" ------------------------------------------------------------------------------ -- | Expansion of a bound name inside a textarea-tag textareaExpansion :: H.Assertion textareaExpansion = renderTest "textarea_expansion" expected where expected = B.concat [ "" ] ------------------------------------------------------------------------------ -- | Expansion of a bound name inside a div-tag divExpansion :: H.Assertion divExpansion = renderTest "div_expansion" expected where expected = "
foo
" ------------------------------------------------------------------------------ -- | Handling of and bound parameters in a bound tag. bindParam :: H.Assertion bindParam = renderTest "bind_param" "
  • Hi there world
    • " ------------------------------------------------------------------------------ -- | Handling of and bound parameters in a bound tag. attrSpliceContext :: H.Assertion attrSpliceContext = renderTest "attrsubtest2" "linkfoo" ------------------------------------------------------------------------------ -- | Markdown test on supplied text markdownTextTest :: H.Assertion markdownTextTest = do hs <- loadEmpty mempty mempty mempty mempty result <- evalHeistT markdownSplice (X.TextNode "This *is* a test.") hs H.assertEqual "Markdown text" markdownHtmlExpected (B.filter (/= '\n') $ toByteString $ X.render (X.HtmlDocument X.UTF8 Nothing result)) ------------------------------------------------------------------------------ applyTest :: H.Assertion applyTest = do es <- loadEmpty mempty mempty mempty mempty res <- evalHeistT applyImpl (X.Element "apply" [("template", "nonexistant")] []) es H.assertEqual "apply nothing" [] res ------------------------------------------------------------------------------ ignoreTest :: H.Assertion ignoreTest = do es <- loadEmpty mempty mempty mempty mempty res <- evalHeistT ignoreImpl (X.Element "ignore" [("tag", "ignorable")] [X.TextNode "This should be ignored"]) es H.assertEqual " tag" [] res lookupTemplateTest :: IO () lookupTemplateTest = do hs <- loadHS "templates" let k = do modifyHS (\st -> st { _curContext = ["foo"] }) getsHS $ (\hs' -> lookupTemplate "/user/menu" hs' _templateMap) res <- runHeistT k (X.TextNode "") hs H.assertBool "lookup context test" $ isJust $ fst res ------------------------------------------------------------------------------ xmlNotHtmlTest :: H.Assertion xmlNotHtmlTest = renderTest "rss" expected where expected = "http://www.devalot.com/" ------------------------------------------------------------------------------ identStartChar :: [Char] identStartChar = ['a'..'z'] ------------------------------------------------------------------------------ identChar :: [Char] identChar = '_' : identStartChar ------------------------------------------------------------------------------ textGen :: Gen [Char] textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar) ------------------------------------------------------------------------------ limitedDepth :: Int -> Gen X.Node limitedDepth 0 = liftM (X.TextNode . T.pack) textGen limitedDepth n = oneof [ liftM (X.TextNode . T.pack) textGen , liftM3 X.Element arbitrary (liftM (take 2) arbitrary) (liftM (take 3) $ listOf $ limitedDepth (n - 1)) ] ------------------------------------------------------------------------------ -- | Returns the number of unique insertion points in the tree. -- If h = insertAt f n g", the following property holds: -- insSize h == (insSize f) + (insSize g) - 1 insSize :: [X.Node] -> Int insSize ns = 1 + (sum $ map nodeSize ns) where nodeSize (X.Element _ _ c) = 1 + (insSize c) nodeSize _ = 1 ------------------------------------------------------------------------------ insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node] insertAt elems 0 ns = elems ++ ns insertAt elems _ [] = elems insertAt elems n list = maybe [] X.topNodes $ evalState (processNode elems $ fromJust $ X.fromNodes list) n ------------------------------------------------------------------------------ move :: Insert () move = modify (\x -> x - 1) ------------------------------------------------------------------------------ processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor) processNode elems loc = liftM2 mplus (move >> goDown loc) (move >> goRight loc) where goDown l = case X.current l of X.TextNode _ -> modify (+1) >> return Nothing X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems) X.firstChild l X.Comment _ -> return Nothing goRight = doneCheck (Just . X.insertManyRight elems) X.right doneCheck insertFunc next l = do s <- get if s == 0 then return $ insertFunc l else maybe (return Nothing) (processNode elems) $ next l ------------------------------------------------------------------------------ newtype Name = Name { unName :: Text } deriving (Show) instance Arbitrary Name where arbitrary = do x <- elements identStartChar n <- choose (4,10) rest <- vectorOf n $ elements identChar return $ Name $ T.pack (x:rest) instance Arbitrary X.Node where arbitrary = limitedDepth 3 shrink (X.Element _ [] []) = [] shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] shrink (X.Element n (_:as) []) = [X.Element n as []] shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] shrink _ = [] instance Arbitrary T.Text where arbitrary = liftM unName arbitrary -- -- Code for inserting nodes into any point of a tree -- type Insert a = State Int a ------------------------------------------------------------------------------ -- tests -- Data type encapsulating the parameters for a bind operation data Bind = Bind { _bindElemName :: Name , _bindChildren :: [X.Node] , _bindDoc :: [X.Node] , _bindPos :: Int , _bindRefPos :: Int } -- deriving (Show) instance Arbitrary Bind where arbitrary = do name <- arbitrary kids <- liftM (take 3) arbitrary doc <- liftM (take 5) arbitrary let s = insSize doc loc <- choose (0, s - 1) loc2 <- choose (0, s - loc - 1) return $ Bind name kids doc loc loc2 shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r] shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] shrink _ = [] instance Show Bind where show b@(Bind e c d p r) = unlines [ "\n" , "Bind element name: " ++ (show e) , "Bind pos: " ++ (show p) , "Bind ref pos: " ++ (show r) , "Bind document:" , L.unpack $ L.concat $ map formatNode d , "Bind children:" , L.unpack $ L.concat $ map formatNode c , "Result:" , L.unpack $ L.concat $ map formatNode $ buildResult b , "Splice result:" , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ do hs <- loadEmpty mempty mempty mempty mempty evalHeistT (runNodeList $ buildBindTemplate b) (X.TextNode "") hs , "Template:" , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b ] where formatNode n = toLazyByteString $ X.render $ X.HtmlDocument X.UTF8 Nothing [n] ------------------------------------------------------------------------------ buildNode :: Text -> Text -> Bind -> X.Node buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c ------------------------------------------------------------------------------ buildBind :: Bind -> X.Node buildBind = buildNode "bind" "tag" ------------------------------------------------------------------------------ empty :: Text -> X.Node empty n = X.Element n [] [] ------------------------------------------------------------------------------ buildBindTemplate :: Bind -> [X.Node] buildBindTemplate s@(Bind n _ d b r) = insertAt [empty $ unName $ n] pos $ withBind where bind = [buildBind s] bindSize = insSize bind withBind = insertAt bind b d pos = b + bindSize - 1 + r ------------------------------------------------------------------------------ buildResult :: Bind -> [X.Node] buildResult (Bind _ c d b r) = insertAt c (b + r) d ------------------------------------------------------------------------------ -- tests data Apply = Apply { _applyName :: Name , _applyCaller :: [X.Node] , _applyCallee :: Template , _applyChildren :: [X.Node] , _applyPos :: Int } deriving (Show) instance Arbitrary Apply where arbitrary = do name <- arbitrary kids <- liftM (take 3) $ listOf $ limitedDepth 2 caller <- liftM (take 5) arbitrary callee <- liftM (take 1) $ listOf $ limitedDepth 3 let s = insSize caller loc <- choose (0, s - 1) return $ Apply name caller callee kids loc ------------------------------------------------------------------------------ buildApplyCaller :: Apply -> [X.Node] buildApplyCaller (Apply name caller _ kids pos) = insertAt [X.Element "apply" [("template", unName name)] kids] pos caller ------------------------------------------------------------------------------ calcCorrect :: Apply -> [X.Node] calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller ------------------------------------------------------------------------------ calcResult :: Apply -> IO [X.Node] calcResult apply@(Apply name _ callee _ _) = do hs <- loadEmpty defaultLoadTimeSplices mempty mempty mempty let hs' = setTemplates (Map.singleton [T.encodeUtf8 $ unName name] (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee) Nothing)) hs evalHeistT (runNodeList $ buildApplyCaller apply) (X.TextNode "") hs' {- - Convenience code for manual ghci experimentation -} --html :: [Node] -> Node --html c = X.Element "html" [] [hhead, body c] --hhead :: Node --hhead = X.Element "head" [] [title, X.Element "script" [] []] --title :: Node --title = X.Element "title" [] [X.Text "Test Page"] --body :: [Node] -> Node --body = X.Element "body" [] -- --para :: Int -> Node --para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n] --para2 :: B.ByteString -> Node --para2 c = X.Element "p" [] [X.Text c] --para3 :: Node --para3 = X.Element "p" [] [X.Text "AHA!"] -- --foo :: Int -> [Node] --foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]] -- --tdoc :: [Node] --tdoc = [para 1, para 2, para 3, para 4] -- --bindElem :: [Node] -> Int -> Int -> Bind --bindElem = Bind (Name "mytag") [para2 "bound paragraph"] -- --addBind :: Bind -> [Node] -> [Node] --addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2 -- --prn :: Node -> IO () --prn = L.putStrLn . formatNode --runTests :: IO () --runTests = defaultMain tests heist-0.13.0.2/test/suite/Heist/Tutorial/0000755000000000000000000000000012226547635016240 5ustar0000000000000000heist-0.13.0.2/test/suite/Heist/Tutorial/AttributeSplices.lhs0000644000000000000000000000536712226547635022251 0ustar0000000000000000Attribute Splices ================= Attribute splices are new in Heist 0.10. They solve the problem of wanting to be able to dynamically make empty attributes appear or disappear with a splice without binding a splice to the whole tag. This issue comes up most frequently when dealing with empty attributes such as HTML's "disabled" or "checked". > module Heist.Tutorial.AttributeSplices where > import Heist.Tutorial.Imports Consider a page with several radio buttons. You want the correct one to be selected based on the value of a parameter in the HTTP request. The HTML would look something like this: Red Green Blue We want to automatically generate the "checked" attribute appropriately. This could be done with a splice bound to the input tag, but there might be a number of other input tags on the page, so your splice would at best be executed on more tags than necessary and at worst not have the granularity necessary to work properly. The ${} syntax for splices inside of attribute values also won't work because it can only affect an attribute's value. It can't make the attribute disappear entirely. This problem can be solved nicely with attribute splices that have the following type: < type AttrSplice m = Text -> m [(Text, Text)] An attribute splice is a computation in the runtime monad that takes the value of the attribute it is bound to as its argument and returns a list of attributes to substitute back into the tag. Here's how we might implement a splice to solve the above problem. > autocheckedSplice :: Text -> StateT Text IO [(Text, Text)] > autocheckedSplice v = do > val <- get -- app-specific retrieval of the appropriate value here > let checked = if v == val > then [("checked","")] > else [] > return $ ("value", v) : checked In this toy example we are using `StateT Text IO` as our "runtime" monad where the Text state holds the value of the radio button that should be checked. We assume that the current value we're checking against is passed as the bound attribute's value, so we compare that against the value to be checked. Then we return a list with the appropriate value and the checked attribute if necessary. We bind this splice to the "autocheck" attribute by adding it to the hcAttributeSplices list in HeistConfig. To make everything work we use the following markup for our radio buttons: Red Green Blue heist-0.13.0.2/test/suite/Heist/Tutorial/CompiledSplices.lhs0000644000000000000000000003105212226547635022030 0ustar0000000000000000Introduction to Compiled Heist ============================== Before version 0.10, Heist has essentially been an interpreter. It loads your templates and "runs" them whenever a page is served. This is relatively inefficient since a lot of document transformations happen every time the template is requested. For Heist version 0.10 we completely rethought everything with performance in mind. We call it "compiled Heist". The main idea is to do most of your splice processing up front at load time. There is still a mechanism for rendering dynamic information at runtime, but it is faster than the fully interpreted approach that Heist started with. It should also be mentioned that the old "interpreted Heist" is not gone. You can still use the old approach where all the transformations happen at render time. This allows you to upgrade without making sweeping changes to your code, and gradually convert your application to the more performant compiled approach as you see fit. Before we continue it should be mentioned that you are reading real live literate Haskell code from our test suite. All the code you see here is compiled into our test suite and the results automatically checked by our buildbot. So first we need to get some boilerplate and imports out of the way. > {-# LANGUAGE NoMonomorphismRestriction #-} > module Heist.Tutorial.CompiledSplices where > import Heist > import qualified Heist.Compiled as C > import Heist.Tutorial.Imports > import Control.Applicative > import qualified Data.Text as T > import Data.Text.Encoding > import qualified Heist.Compiled.LowLevel as C > import Text.XmlHtml As a review, normal (interpreted) Heist splices are defined like this. < type Splice m = HeistT m m [Node] The type parameter `m` is the runtime execution monad (in a Snap application this will usually be `Handler` or `Snap`). Don't worry about why the `m` is there twice right now. We'll get to that later. The splice's return value is a list of nodes that is substituted back into the document wherever the spliced node was. This kind of splice proccessing involves traversing the DOM, which is inefficient. Compiled Heist is designed so that all the DOM traversals happen once at load time in the IO monad. This is the "compile" phase. The type signature for compiled splices is this. < type Splice n = HeistT n IO (DList (Chunk n)) We see that where Heist splices ran in the m monad, compiled splices run in the IO monad. This also explains why HeistT now has two monad type parameters. The first parameter is a placeholder for the runtime monad and the second parameter is the monad that we're actually running in now. But the key point of the compiled splice type signature is the return value. They return a DList of Chunks. DList is a list that supports efficient insertion to both the front and back of the list. The Chunk type is not exposed publicly, but there are three ways to construct a Chunk. < yieldPure :: Builder -> DList (Chunk m) < yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m) < yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m) If your splice output can be calculated at load time, then you should use `yieldPure` or one of its variants. When you do this, Heist can concatenate all adjacent pure chunks into a single precalculated ByteString that can be rendered very efficiently. If your template needs a value that has to be calculated at runtime, then you should use the `yieldRuntime` constructor and supply a computation in the RuntimeSplice monad transformer that is parameterized by `m` which we saw above is the runtime monad. Occasionally you might want to run a runtime side effect that doesn't actually insert any data into your template. The `yieldRuntimeEffect` function gives you that capability. An Example ========== With that background, let's get to a real example. > stateSplice :: C.Splice (StateT Int IO) > stateSplice = return $ C.yieldRuntimeText $ do > val <- lift get > return $ pack $ show (val+1) Here we see that our splice's runtime monad is `StateT Int IO`. This makes for a simple example that can clearly demonstrate the different contexts that we are operating in. To make things more clear, here's a version with some print statements that clarify the details of which monad is executed when. > stateSplice2 :: C.Splice (StateT Int IO) > stateSplice2 = do > -- :: C.Splice (StateT Int IO) > lift $ putStrLn "This executed at load time" > let res = C.yieldRuntimeText $ do > -- :: RuntimeSplice (StateT Int IO) a > lift $ lift $ putStrLn "This executed at run/render time" > val <- lift get > return $ pack $ show (val+1) > lift $ putStrLn "This also executed at load time" > return res Note here that even though the type parameter to C.Splice is a monad, it is not a monad transformer. RuntimeSplice, however, is. Now let's look at a simple load function that sets up a default HeistState and loads templates from a directory with compiled splices. > load :: MonadIO n > => FilePath > -> Splices (C.Splice n) > -> IO (HeistState n) > load baseDir splices = do > tmap <- runEitherT $ do > let hc = HeistConfig mempty defaultLoadTimeSplices splices mempty > [loadTemplates baseDir] > initHeist hc > either (error . concat) return tmap Here's a function demonstrating all of this in action. > runWithStateSplice :: FilePath > -> IO ByteString > runWithStateSplice baseDir = do > hs <- load baseDir ("div" ## stateSplice) > let runtime = fromJust $ C.renderTemplate hs "index" > builder <- evalStateT (fst runtime) 2 > return $ toByteString builder First this function loads the templates with the above compiled splice. You have to specify all the compiled splices in the call to loadTemplates because loadTemplates takes care of compiling all the templates up front. If you were able to bind compiled splices later, then all the templates would have to be recompiled, a potentially expensive operation. Next, the function renders the template called "index" using a runtime (StateT Int IO) seeded with a value of 2 and returns the resulting ByteString. Now let's look at a more complicated example. We want to render a data structure with a compiled splice. > data Person = Person > { pFirstName :: Text > , pLastName :: Text > , pAge :: Int > } > > personSplices :: Monad n > => Splices (RuntimeSplice n Person -> C.Splice n) > personSplices = mapS (C.pureSplice . C.textSplice) $ do > "firstName" ## pFirstName > "lastName" ## pLastName > "age" ## pack . show . pAge > > peopleSplice :: (Monad n) > => RuntimeSplice n [Person] > -> C.Splice n > peopleSplice = C.manyWithSplices C.runChildren personSplices > > allPeopleSplice :: C.Splice (StateT [Person] IO) > allPeopleSplice = peopleSplice (lift get) > > personListTest :: FilePath > -> IO ByteString > personListTest baseDir = do > hs <- load baseDir ("people" ## allPeopleSplice) > let runtime = fromJust $ C.renderTemplate hs "people" > builder <- evalStateT (fst runtime) > [ Person "John" "Doe" 42 > , Person "Jane" "Smith" 21 > ] > return $ toByteString builder Disadvantages of Compiled Heist =============================== Compiled Heist is faster than the original interpreted approach, but as with most things in computing there is a tradeoff. Compiled Heist is strictly less powerful than interpreted Heist. There are two things that compiled Heist loses: the ability to bind new splices on the fly at runtime and splice recursion/composability. The first point follows immediately from the definition of compiled Heist. When you decide to do all your splice DOM traversals once at load time you're unavoidably limited to only those splices that you defined at load time. But this seems to be a good pattern to use in general because debugging your splices will be easier if you don't have to consider the possibility that the handler that binds them didn't run. The loss of recursion/composability happens because of the change in the type signature of splices. Interpreted splices are a essentially function `[Node] -> m [Node]`. This means that the output of one splice can be the input of another splice (including itself). Compiled splices are a function `[Node] -> IO (DList (Chunk m))`. Therefore, once a splice processes some nodes, the output is no longer something that can be passed into other splices. This composability turns out to be a very powerful feature. Head merging is one feature that can't be done without it. Head merging allows you to put `` tags anyhere in any template and have them all merged into a single `` tag at the top of your HTML document. This is useful because it allows you to keep concerns localized. For instance, you can have a template represent a small piece of functionality that uses a less common javascript or CSS file. Instead of having to depend on that resource being included in the top-level `` tag, you can include it in a `` tag right where you're using it. Then it will only be included on your pages when you are using the markup that needs it. Our implementation of head merging uses a splice bound to the `` tag. This splice removes all the `` nodes from its children, combines them, and inserts them as its first child. This won't work unless the `` splice first runs all its children to make sure all `` and `` tags have happened first. And that is impossible to do with compiled splices. To get around this problem we added the concept of load time splices. Load time splices are just interpreted splices that are completely executed at load time. If interpreted splices have type `[Node] -> m [Node]` where m is the runtime monad, then load time splices have type `[Node] -> IO [Node]`, where IO is the monad being executed at load time. Load time splices give you the power and composability of interpreted splices as long as they are performing transformations that don't require runtime data. All of the built-in splices that we ship with Heist work as load time splices. So you can still have head merging by including our html splice in the load time splice list in your HeistConfig. A More Involved Example ======================= The person example above is a very common and useful pattern for using dynamic data in splices. But it has the simplification that it always generates output the same way. Sometimes you might want a splice's output to have one form in some cases and a different form in other cases. A simple example is a splice that reads some kind of a key from a request parameter then looks that key up in some kind of map. If the key is present the splice uses its child nodes as a view for the retrieved value, otherwise it outputs an error message. This pattern is a little tricky because you're making decisions about what to render based on runtime data, but the actual rendering of child nodes has to be done at load time. To bridge the gap and allow communication between load time and runtime processing we provide the Promise data type. A Promise is kind of like an IORef except that operations on them are restricted to the appropriate Heist context. You create a new empty promise in the HeistT n IO (load time) monad, and you operate on it in the RuntimeSplice monad. Here's an example of how to use a promise manually to render a splice differently in the case of failure. < failingSplice :: MonadSnap m => C.Splice m < failingSplice = do < children <- childNodes <$> getParamNode < promise <- C.newEmptyPromise < outputChildren <- C.withSplices C.runChildren splices (C.getPromise promise) < return $ C.yieldRuntime $ do < -- :: RuntimeSplice m Builder < mname <- lift $ getParam "username" < let err = return $ fromByteString "Must supply a username" < single name = do < euser <- lift $ lookupUser name < either (return . fromByteString . encodeUtf8 . T.pack) < doUser euser < where < doUser value = do < C.putPromise promise (name, value) < C.codeGen outputChildren < maybe err single mname < < < splices :: Monad n < => Splices (RuntimeSplice n (Text, Text) -> C.Splice n) < splices = mapS (C.pureSplice . C.nodeSplice) $ do < "user" ## (:[]) . TextNode . fst < "value" ## (:[]) . TextNode . snd heist-0.13.0.2/test/suite/Heist/Tutorial/Imports.hs0000644000000000000000000000115612226547635020234 0ustar0000000000000000module Heist.Tutorial.Imports ( module Blaze.ByteString.Builder , module Control.Monad , module Control.Monad.Trans , module Data.Maybe , module Data.Monoid , ST.get , ST.StateT(..) , ST.evalStateT , T.Text , T.pack , ByteString , runEitherT ) where import Blaze.ByteString.Builder import Control.Error (runEitherT) import Control.Monad import Control.Monad.Trans import qualified Control.Monad.Trans.State as ST import Data.ByteString.Char8 (ByteString) import Data.Maybe import Data.Monoid import qualified Data.Text as T heist-0.13.0.2/test/templates/0000755000000000000000000000000012226547635014226 5ustar0000000000000000heist-0.13.0.2/test/templates/a.tpl0000644000000000000000000000002012226547635015157 0ustar0000000000000000/a heist-0.13.0.2/test/templates/attr_splice.tpl0000644000000000000000000000012212226547635017253 0ustar0000000000000000 heist-0.13.0.2/test/templates/attrs.tpl0000644000000000000000000000016412226547635016105 0ustar0000000000000000Empty attribute No ident capture
    heist-0.13.0.2/test/templates/attrsubtest1.tpl0000644000000000000000000000002212226547635017406 0ustar0000000000000000 heist-0.13.0.2/test/templates/attrsubtest2.tpl0000644000000000000000000000021212226547635017410 0ustar0000000000000000asdflinkfoo heist-0.13.0.2/test/templates/bind-attrs.tpl0000644000000000000000000000006612226547635017020 0ustar0000000000000000zzzzz
    heist-0.13.0.2/test/templates/bind_param.tpl0000644000000000000000000000020512226547635017040 0ustar0000000000000000
    • worldHi therehello heist-0.13.0.2/test/templates/cache.tpl0000644000000000000000000000004612226547635016012 0ustar0000000000000000 heist-0.13.0.2/test/templates/div_expansion.tpl0000644000000000000000000000006212226547635017613 0ustar0000000000000000foo
    heist-0.13.0.2/test/templates/index.tpl0000644000000000000000000000031212226547635016052 0ustar0000000000000000 ultralongname
    /index
    heist-0.13.0.2/test/templates/ioc.tpl0000644000000000000000000000007712226547635015525 0ustar0000000000000000 Inversion of control content heist-0.13.0.2/test/templates/json.tpl0000644000000000000000000000003512226547635015716 0ustar0000000000000000 heist-0.13.0.2/test/templates/json_object.tpl0000644000000000000000000000033312226547635017245 0ustar0000000000000000 heist-0.13.0.2/test/templates/json_snippet.tpl0000644000000000000000000000003712226547635017462 0ustar0000000000000000 heist-0.13.0.2/test/templates/markdown.tpl0000644000000000000000000000003312226547635016565 0ustar0000000000000000 heist-0.13.0.2/test/templates/page.tpl0000644000000000000000000000022412226547635015661 0ustar0000000000000000 heist-0.13.0.2/test/templates/people.tpl0000644000000000000000000000010612226547635016230 0ustar0000000000000000

    , : years old

     heist-0.13.0.2/test/templates/post.tpl0000644000000000000000000000007012226547635015731 0ustar0000000000000000

    heist-0.13.0.2/test/templates/readme.txt0000644000000000000000000000013212226547635016220 0ustar0000000000000000This file intentionally doesn't have a .tpl extension to get test coverage for this case. heist-0.13.0.2/test/templates/test.md0000644000000000000000000000002212226547635015521 0ustar0000000000000000This *is* a test. heist-0.13.0.2/test/templates/textarea_expansion.tpl0000644000000000000000000000007412226547635020651 0ustar0000000000000000foo heist-0.13.0.2/test/templates/title_expansion.tpl0000644000000000000000000000006612226547635020156 0ustar0000000000000000foo<mytext/> heist-0.13.0.2/test/templates/bar/0000755000000000000000000000000012226547635014772 5ustar0000000000000000heist-0.13.0.2/test/templates/bar/a.tpl0000644000000000000000000000002412226547635015727 0ustar0000000000000000/bar/a heist-0.13.0.2/test/templates/bar/index.tpl0000644000000000000000000000003012226547635016613 0ustar0000000000000000/bar/index heist-0.13.0.2/test/templates/bind-apply-interaction/0000755000000000000000000000000012226547635020602 5ustar0000000000000000heist-0.13.0.2/test/templates/bind-apply-interaction/_outer.tpl0000644000000000000000000000021112226547635022612 0ustar0000000000000000====== This is a test. bind content Another test line. Last test line. heist-0.13.0.2/test/templates/bind-apply-interaction/caller.tpl0000644000000000000000000000005712226547635022567 0ustar0000000000000000apply content heist-0.13.0.2/test/templates/foo/0000755000000000000000000000000012226547635015011 5ustar0000000000000000heist-0.13.0.2/test/templates/foo/a.tpl0000644000000000000000000000000712226547635015747 0ustar0000000000000000/foo/a heist-0.13.0.2/test/templates/foo/b.tpl0000644000000000000000000000000712226547635015750 0ustar0000000000000000/foo/b heist-0.13.0.2/test/templates/foo/markdown-chdir.tpl0000644000000000000000000000036612226547635020450 0ustar0000000000000000Different directory markdown This file doesn't have any actual test code referring to it because compiled Heist will automatically fail the whole test suite if the case tested by this template isn't tested correctly. heist-0.13.0.2/test/templates/foo/markdown-origdir.tpl0000644000000000000000000000007512226547635021013 0ustar0000000000000000 heist-0.13.0.2/test/templates/foo/test2.md0000644000000000000000000000003012226547635016365 0ustar0000000000000000This *is* another test. heist-0.13.0.2/test/templates/head_merge/0000755000000000000000000000000012226547635016306 5ustar0000000000000000heist-0.13.0.2/test/templates/head_merge/index.tpl0000644000000000000000000000013712226547635020137 0ustar0000000000000000
    index page
     heist-0.13.0.2/test/templates/head_merge/nav.tpl0000644000000000000000000000007112226547635017611 0ustar0000000000000000
    nav bar
    heist-0.13.0.2/test/templates/head_merge/wrap.tpl0000644000000000000000000000016112226547635017776 0ustar0000000000000000 heist-0.13.0.2/test/templates/user/0000755000000000000000000000000012226547635015204 5ustar0000000000000000heist-0.13.0.2/test/templates/user/main.tpl0000644000000000000000000000012112226547635016643 0ustar0000000000000000 User Page heist-0.13.0.2/test/templates/user/menu.tpl0000644000000000000000000000010012226547635016660 0ustar0000000000000000
    • Entries
    • Post
    • Logout
    heist-0.13.0.2/test/templates/user/admin/0000755000000000000000000000000012226547635016274 5ustar0000000000000000heist-0.13.0.2/test/templates/user/admin/main.tpl0000644000000000000000000000006312226547635017740 0ustar0000000000000000 Admin Page heist-0.13.0.2/test/templates/user/admin/menu.tpl0000644000000000000000000000007512226547635017763 0ustar0000000000000000
    • Manage Users
    • Configure Site
    heist-0.13.0.2/test/templates-bad/0000755000000000000000000000000012226547635014752 5ustar0000000000000000heist-0.13.0.2/test/templates-bad/apply-missing-attr.tpl0000644000000000000000000000003012226547635021230 0ustar0000000000000000 noroot heist-0.13.0.2/test/templates-bad/apply-template-not-found.tpl0000644000000000000000000000007312226547635022340 0ustar0000000000000000 This template is missing heist-0.13.0.2/test/templates-bad/bind-infinite-loop.tpl0000644000000000000000000000006012226547635021155 0ustar0000000000000000

    line

     heist-0.13.0.2/test/templates-bad/bind-missing-attr.tpl0000644000000000000000000000004012226547635021020 0ustar0000000000000000

    line