heist-1.1.0.1/0000755000000000000000000000000013363531400011150 5ustar0000000000000000heist-1.1.0.1/README.SNAP.md0000644000000000000000000000227313363531400013173 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-1.1.0.1/haddock.sh0000755000000000000000000000044513363531400013107 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-1.1.0.1/Setup.hs0000644000000000000000000000005713363531400012606 0ustar0000000000000000import Distribution.Simple main = defaultMain heist-1.1.0.1/heist.cabal0000644000000000000000000002141513363531400013253 0ustar0000000000000000name: heist version: 1.1.0.1 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.8.0.4 homepage: http://snapframework.com/ category: Web, Snap Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 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/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/backslash.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_array.tpl test/templates/json_object.tpl, test/templates/json_snippet.tpl, test/templates/markdown.tpl, test/templates/namespaces.tpl test/templates/page.tpl, test/templates/pandoc.tpl test/templates/pandocdiv.tpl test/templates/people.tpl, test/templates/post.tpl, test/templates/readme.txt, test/templates/rss.xtpl 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, test/templates-defer/test.tpl, test/templates-loaderror/_error.tpl, test/templates-loaderror/_ok.tpl, test/templates-loaderror/test.tpl, test/templates-nsbind/nsbind.tpl, test/templates-nsbind/nsbinderror.tpl, test/templates-ns-nested/test.tpl, test/templates-nscall/_call.tpl, test/templates-nscall/_invalid.tpl, test/templates-nscall/nscall.tpl, TODO Library hs-source-dirs: src exposed-modules: Heist, Heist.Compiled, Heist.Compiled.LowLevel, Heist.Internal.Types, Heist.Interpreted, 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.Internal.Types.HeistState, Heist.Interpreted.Internal build-depends: aeson >= 0.6 && < 1.5, attoparsec >= 0.10 && < 0.14, base >= 4.5 && < 4.13, blaze-builder >= 0.2 && < 0.5, blaze-html >= 0.4 && < 0.10, bytestring >= 0.9 && < 0.11, containers >= 0.2 && < 0.7, directory >= 1.1 && < 1.4, directory-tree >= 0.10 && < 0.13, dlist >= 0.5 && < 0.9, filepath >= 1.3 && < 1.5, hashable >= 1.1 && < 1.3, lifted-base >= 0.2 && < 0.3, map-syntax >= 0.3 && < 0.4, monad-control >= 0.3 && < 1.1, mtl >= 2.0 && < 2.3, process >= 1.1 && < 1.7, random >= 1.0.1.0 && < 1.2, text >= 0.10 && < 1.3, time >= 1.1 && < 1.10, transformers >= 0.3 && < 0.6, transformers-base >= 0.4 && < 0.5, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.13, xmlhtml >= 0.2.3.5 && < 0.3 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Extensions: GeneralizedNewtypeDeriving, PackageImports, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, TypeSynonymInstances, NoMonomorphismRestriction source-repository head type: git location: https://github.com/snapframework/heist.git Test-suite testsuite hs-source-dirs: src test/suite type: exitcode-stdio-1.0 main-is: TestSuite.hs build-depends: HUnit >= 1.2 && < 2, QuickCheck >= 2 && < 2.13, lens >= 4.3 && < 4.18, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2.7 && < 0.4, test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, aeson, attoparsec, base, bifunctors >= 5.3 && < 5.6, blaze-builder, blaze-html, bytestring, containers, directory, directory-tree, dlist, filepath, hashable, lifted-base, map-syntax, monad-control, mtl, process, random, text, time, transformers, transformers-base, unordered-containers, vector, xmlhtml if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 if impl(ghc >= 7.8) && impl(ghc < 7.10) build-depends: transformers-compat >= 0.3 && < 0.7 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded Extensions: OverloadedStrings Benchmark benchmark hs-source-dirs: src test/suite type: exitcode-stdio-1.0 main-is: Benchmark.hs build-depends: HUnit, criterion >= 1.0 && < 1.6, criterion-measurement >= 0.1 && < 0.2, test-framework, test-framework-hunit, -- Copied from regular dependencies: aeson, attoparsec, base, blaze-builder, blaze-html, bytestring, containers, directory, directory-tree, dlist, filepath, hashable, lifted-base, map-syntax, monad-control, mtl, process, random, statistics >= 0.11 && < 0.16, text, time, transformers, transformers-base, unordered-containers, vector, xmlhtml if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 if impl(ghc >= 7.8) && impl(ghc < 7.10) build-depends: transformers-compat ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts Extensions: GeneralizedNewtypeDeriving, PackageImports, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, TypeSynonymInstances, NoMonomorphismRestriction heist-1.1.0.1/LICENSE0000644000000000000000000000274513363531400012165 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-1.1.0.1/TODO0000644000000000000000000000017413363531400011642 0ustar0000000000000000* Fix handling of ".." in apply tags Ongoing ------- * Improve test coverage * Head merging (ala the Lift Web Framework) heist-1.1.0.1/CONTRIBUTORS0000644000000000000000000000041613363531400013031 0ustar0000000000000000Doug Beardsley Gregory Collins Carl Howells Edward Kmett Will Langstroth Shane O'Brien James Sanders Mark Wright heist-1.1.0.1/README.md0000644000000000000000000000302713363531400012431 0ustar0000000000000000# Heist [![Build Status](https://travis-ci.org/snapframework/heist.svg?branch=master)](https://travis-ci.org/snapframework/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-1.1.0.1/.ghci0000644000000000000000000000021513363531400012061 0ustar0000000000000000:set -XOverloadedStrings :set -XCPP :set -Wall :set -isrc :set -itest/suite :set -hide-package MonadCatchIO-mtl :set -hide-package monads-tf heist-1.1.0.1/test/0000755000000000000000000000000013363531400012127 5ustar0000000000000000heist-1.1.0.1/test/templates-loaderror/0000755000000000000000000000000013363531400016114 5ustar0000000000000000heist-1.1.0.1/test/templates-loaderror/_error.tpl0000644000000000000000000000003313363531400020121 0ustar0000000000000000 heist-1.1.0.1/test/templates-loaderror/test.tpl0000644000000000000000000000004113363531400017607 0ustar0000000000000000 heist-1.1.0.1/test/templates-loaderror/_ok.tpl0000644000000000000000000000002513363531400017402 0ustar0000000000000000 heist-1.1.0.1/test/templates-defer/0000755000000000000000000000000013363531400015210 5ustar0000000000000000heist-1.1.0.1/test/templates-defer/test.tpl0000644000000000000000000000031713363531400016711 0ustar0000000000000000 heist-1.1.0.1/test/templates-nscall/0000755000000000000000000000000013363531400015377 5ustar0000000000000000heist-1.1.0.1/test/templates-nscall/_invalid.tpl0000644000000000000000000000001513363531400017701 0ustar0000000000000000 heist-1.1.0.1/test/templates-nscall/nscall.tpl0000644000000000000000000000006313363531400017373 0ustar0000000000000000Top Inside 1 Inside 2 heist-1.1.0.1/test/templates-nscall/_call.tpl0000644000000000000000000000002013363531400017162 0ustar0000000000000000Called heist-1.1.0.1/test/templates-nsbind/0000755000000000000000000000000013363531400015400 5ustar0000000000000000heist-1.1.0.1/test/templates-nsbind/nsbinderror.tpl0000644000000000000000000000016113363531400020446 0ustar0000000000000000Alpha heist-1.1.0.1/test/templates-nsbind/nsbind.tpl0000644000000000000000000000006413363531400017376 0ustar0000000000000000Alpha Beta Gamma heist-1.1.0.1/test/templates-ns-nested/0000755000000000000000000000000013363531400016023 5ustar0000000000000000heist-1.1.0.1/test/templates-ns-nested/test.tpl0000644000000000000000000000002413363531400017517 0ustar0000000000000000
heist-1.1.0.1/test/templates/0000755000000000000000000000000013363531400014125 5ustar0000000000000000heist-1.1.0.1/test/templates/json_array.tpl0000644000000000000000000000017513363531400017020 0ustar0000000000000000, and heist-1.1.0.1/test/templates/index.tpl0000644000000000000000000000031213363531400015751 0ustar0000000000000000 ultralongname
/index
heist-1.1.0.1/test/templates/json.tpl0000644000000000000000000000003513363531400015615 0ustar0000000000000000 heist-1.1.0.1/test/templates/post.tpl0000644000000000000000000000007013363531400015630 0ustar0000000000000000

heist-1.1.0.1/test/templates/markdown.tpl0000644000000000000000000000003313363531400016464 0ustar0000000000000000 heist-1.1.0.1/test/templates/pandocdiv.tpl0000644000000000000000000000006413363531400016615 0ustar0000000000000000 heist-1.1.0.1/test/templates/json_object.tpl0000644000000000000000000000033313363531400017144 0ustar0000000000000000 heist-1.1.0.1/test/templates/cache.tpl0000644000000000000000000000004613363531400015711 0ustar0000000000000000 heist-1.1.0.1/test/templates/bind_param.tpl0000644000000000000000000000020513363531400016737 0ustar0000000000000000
    • worldHi therehello heist-1.1.0.1/test/templates/namespaces.tpl0000644000000000000000000000013113363531400016760 0ustar0000000000000000Alpha Inside foo Beta Inside h:foo End heist-1.1.0.1/test/templates/attrs.tpl0000644000000000000000000000016413363531400016004 0ustar0000000000000000Empty attribute No ident capture
    heist-1.1.0.1/test/templates/backslash.tpl0000644000000000000000000000003113363531400016573 0ustar0000000000000000 heist-1.1.0.1/test/templates/attr_splice.tpl0000644000000000000000000000012213363531400017152 0ustar0000000000000000 heist-1.1.0.1/test/templates/rss.xtpl0000644000000000000000000000010313363531400015637 0ustar0000000000000000http://www.devalot.com/ heist-1.1.0.1/test/templates/bind-attrs.tpl0000644000000000000000000000006613363531400016717 0ustar0000000000000000zzzzz
    heist-1.1.0.1/test/templates/ioc.tpl0000644000000000000000000000007713363531400015424 0ustar0000000000000000 Inversion of control content heist-1.1.0.1/test/templates/title_expansion.tpl0000644000000000000000000000006613363531400020055 0ustar0000000000000000foo<mytext/> heist-1.1.0.1/test/templates/readme.txt0000644000000000000000000000013213363531400016117 0ustar0000000000000000This file intentionally doesn't have a .tpl extension to get test coverage for this case. heist-1.1.0.1/test/templates/json_snippet.tpl0000644000000000000000000000003713363531400017361 0ustar0000000000000000 heist-1.1.0.1/test/templates/people.tpl0000644000000000000000000000010613363531400016127 0ustar0000000000000000

    , : years old

     heist-1.1.0.1/test/templates/test.md0000644000000000000000000000002213363531400015420 0ustar0000000000000000This *is* a test. heist-1.1.0.1/test/templates/textarea_expansion.tpl0000644000000000000000000000007413363531400020550 0ustar0000000000000000foo heist-1.1.0.1/test/templates/div_expansion.tpl0000644000000000000000000000006213363531400017512 0ustar0000000000000000foo
    heist-1.1.0.1/test/templates/attrsubtest2.tpl0000644000000000000000000000021213363531400017307 0ustar0000000000000000asdflinkfoo heist-1.1.0.1/test/templates/page.tpl0000644000000000000000000000022413363531400015560 0ustar0000000000000000 heist-1.1.0.1/test/templates/pandoc.tpl0000644000000000000000000000003613363531400016111 0ustar0000000000000000 heist-1.1.0.1/test/templates/a.tpl0000644000000000000000000000002013363531400015056 0ustar0000000000000000/a heist-1.1.0.1/test/templates/attrsubtest1.tpl0000644000000000000000000000002213363531400017305 0ustar0000000000000000 heist-1.1.0.1/test/templates/head_merge/0000755000000000000000000000000013363531400016205 5ustar0000000000000000heist-1.1.0.1/test/templates/head_merge/nav.tpl0000644000000000000000000000007113363531400017510 0ustar0000000000000000
    nav bar
    heist-1.1.0.1/test/templates/head_merge/index.tpl0000644000000000000000000000013713363531400020036 0ustar0000000000000000
    index page
     heist-1.1.0.1/test/templates/head_merge/wrap.tpl0000644000000000000000000000016113363531400017675 0ustar0000000000000000 heist-1.1.0.1/test/templates/bind-apply-interaction/0000755000000000000000000000000013363531400020501 5ustar0000000000000000heist-1.1.0.1/test/templates/bind-apply-interaction/caller.tpl0000644000000000000000000000005713363531400022466 0ustar0000000000000000apply content heist-1.1.0.1/test/templates/bind-apply-interaction/_outer.tpl0000644000000000000000000000021113363531400022511 0ustar0000000000000000====== This is a test. bind content Another test line. Last test line. heist-1.1.0.1/test/templates/user/0000755000000000000000000000000013363531400015103 5ustar0000000000000000heist-1.1.0.1/test/templates/user/main.tpl0000644000000000000000000000012113363531400016542 0ustar0000000000000000 User Page heist-1.1.0.1/test/templates/user/menu.tpl0000644000000000000000000000010013363531400016557 0ustar0000000000000000
    • Entries
    • Post
    • Logout
    heist-1.1.0.1/test/templates/user/admin/0000755000000000000000000000000013363531400016173 5ustar0000000000000000heist-1.1.0.1/test/templates/user/admin/main.tpl0000644000000000000000000000006313363531400017637 0ustar0000000000000000 Admin Page heist-1.1.0.1/test/templates/user/admin/menu.tpl0000644000000000000000000000007513363531400017662 0ustar0000000000000000
    • Manage Users
    • Configure Site
    heist-1.1.0.1/test/templates/foo/0000755000000000000000000000000013363531400014710 5ustar0000000000000000heist-1.1.0.1/test/templates/foo/test2.md0000644000000000000000000000003013363531400016264 0ustar0000000000000000This *is* another test. heist-1.1.0.1/test/templates/foo/markdown-chdir.tpl0000644000000000000000000000036613363531400020347 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-1.1.0.1/test/templates/foo/markdown-origdir.tpl0000644000000000000000000000007513363531400020712 0ustar0000000000000000 heist-1.1.0.1/test/templates/foo/b.tpl0000644000000000000000000000000713363531400015647 0ustar0000000000000000/foo/b heist-1.1.0.1/test/templates/foo/a.tpl0000644000000000000000000000000713363531400015646 0ustar0000000000000000/foo/a heist-1.1.0.1/test/templates/bar/0000755000000000000000000000000013363531400014671 5ustar0000000000000000heist-1.1.0.1/test/templates/bar/index.tpl0000644000000000000000000000003013363531400016512 0ustar0000000000000000/bar/index heist-1.1.0.1/test/templates/bar/a.tpl0000644000000000000000000000002413363531400015626 0ustar0000000000000000/bar/a heist-1.1.0.1/test/suite/0000755000000000000000000000000013363531400013260 5ustar0000000000000000heist-1.1.0.1/test/suite/TestSuite.hs0000644000000000000000000000123713363531400015550 0ustar0000000000000000module Main where import System.Directory import Test.Framework (defaultMain, testGroup) import qualified Heist.Interpreted.Tests import qualified Heist.Compiled.Tests import qualified Heist.Tests main :: IO () main = do -- Need to change directory after we switched to cabal test infra setCurrentDirectory "test" 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-1.1.0.1/test/suite/Benchmark.hs0000644000000000000000000000774513363531400015523 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Main where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Concurrent import Control.Exception (evaluate) import Control.Monad import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import Criterion import Criterion.Main import Criterion.Measurement hiding (getTime) import qualified Data.ByteString as B import qualified Data.DList as DL import Data.Maybe import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding import Data.Time.Clock import System.Environment import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist import Heist.Common import qualified Heist.Compiled as C import qualified Heist.Compiled.Internal as CI import qualified Heist.Interpreted as I import Heist.TestCommon import Heist.Internal.Types ------------------------------------------------------------------------------ loadWithCache baseDir = do etm <- runExceptT $ do let sc = SpliceConfig mempty defaultLoadTimeSplices mempty mempty [loadTemplates baseDir] (const True) ExceptT $ initHeistWithCacheTag $ HeistConfig sc "" False either (error . unlines) (return . fst) etm main = do (dir:file:_) <- getArgs applyComparison dir file justRender dir = do let page = "faq" pageStr = T.unpack $ decodeUtf8 page hs <- loadWithCache dir let !compiledTemplate = fst $! fromJust $! C.renderTemplate hs page compiledAction = do res <- compiledTemplate return $! toByteString $! res out <- compiledAction putStrLn $ "Rendered ByteString of length "++(show $ B.length out) B.writeFile (pageStr++".out.compiled."++dir) $ out defaultMain [ bench (pageStr++"-compiled (just render)") (whnfIO compiledAction) ] ------------------------------------------------------------------------------ applyComparison :: FilePath -> 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") (whnfIO 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-1.1.0.1/test/suite/Heist/0000755000000000000000000000000013363531400014334 5ustar0000000000000000heist-1.1.0.1/test/suite/Heist/Tests.hs0000644000000000000000000002024113363531400015771 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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.Map.Syntax 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.Internal.Types import qualified Heist.Interpreted as I import Heist.Splices.Cache import Heist.Splices.Html import Heist.TemplateDirectory import Heist.Tutorial.AttributeSplices import Heist.Tutorial.CompiledSplices 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 #if MIN_VERSION_base(4,9,0) ["templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in \nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" ,"templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in \nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" ] #else ["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 " ] #endif 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 = "\n\n" expected4 = "\n\n" 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) sc = SpliceConfig rSplices mempty dSplices mempty mempty (const True) hc = HeistConfig sc "" False 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\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" ["\nThis is a test." ,"===bind content===\nAnother test line." ,"apply content\nLast test line." ,"\n" ] iExpected = B.unlines ["\nThis 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" expected cOut iOut <- iRender hs "backslash" H.assertEqual "interpreted failure" expected iOut where expected = "\n" heist-1.1.0.1/test/suite/Heist/TestCommon.hs0000644000000000000000000001130013363531400016753 0ustar0000000000000000module Heist.TestCommon where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad.Trans import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) 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 Heist.Internal.Types 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 = runExceptT $ do let sc = SpliceConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir] (const True) ExceptT $ initHeist $ HeistConfig sc "" False ------------------------------------------------------------------------------ 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 = runExceptT $ do let sc = SpliceConfig (defaultInterpretedSplices >> a) (defaultLoadTimeSplices >> b) c d [loadTemplates baseDir] (const True) ExceptT $ initHeist $ HeistConfig sc "" False ------------------------------------------------------------------------------ loadHS :: FilePath -> IO (HeistState IO) loadHS baseDir = do etm <- runExceptT $ do let sc = SpliceConfig defaultInterpretedSplices defaultLoadTimeSplices mempty mempty [loadTemplates baseDir] (const True) ExceptT $ initHeist $ HeistConfig sc "" False 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 sc = SpliceConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d mempty (const True) res <- initHeist $ HeistConfig sc "" False 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 ------------------------------------------------------------------------------ isLeft :: Either e a -> Bool isLeft (Left _) = True isLeft _ = False ------------------------------------------------------------------------------ noteT :: Monad m => e -> MaybeT m a -> ExceptT e m a noteT e ma = do x <- lift $ runMaybeT ma case x of Nothing -> ExceptT $ return (Left e) Just a -> ExceptT $ return (Right a) ------------------------------------------------------------------------------ hoistMaybe :: Monad m => Maybe a -> MaybeT m a hoistMaybe = MaybeT . return heist-1.1.0.1/test/suite/Heist/Tutorial/0000755000000000000000000000000013363531400016137 5ustar0000000000000000heist-1.1.0.1/test/suite/Heist/Tutorial/CompiledSplices.lhs0000644000000000000000000003124213363531400021730 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 Control.Lens > import Data.Map.Syntax 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 <- runExceptT $ do > let sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices > & scCompiledSplices .~ splices > & scTemplateLocations .~ [loadTemplates baseDir] > ExceptT $ initHeist $ emptyHeistConfig & hcNamespace .~ "" > & hcErrorNotBound .~ False > & hcSpliceConfig .~ sc > 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 = mapV (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 < 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.htmlNodeSplice) $ do < "user" ## (:[]) . TextNode . fst < "value" ## (:[]) . TextNode . snd heist-1.1.0.1/test/suite/Heist/Tutorial/AttributeSplices.lhs0000644000000000000000000000536713363531400022150 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-1.1.0.1/test/suite/Heist/Tutorial/Imports.hs0000644000000000000000000000123013363531400020124 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 , runExceptT , ExceptT(..) ) where import Blaze.ByteString.Builder import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Except (ExceptT(..), runExceptT) 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-1.1.0.1/test/suite/Heist/Compiled/0000755000000000000000000000000013363531400016070 5ustar0000000000000000heist-1.1.0.1/test/suite/Heist/Compiled/Tests.hs0000644000000000000000000004170313363531400017533 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Heist.Compiled.Tests where import Blaze.ByteString.Builder import Control.Applicative import Control.Exception import Control.Monad.Trans.Except import Control.Lens import Control.Monad.Trans import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Char import Data.IORef import Data.Maybe import Data.Map.Syntax import Data.Monoid import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding import Test.Framework (Test) import Test.Framework.Providers.HUnit import qualified Test.HUnit as H import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist import Heist.Compiled import Heist.Compiled.Internal import Heist.Internal.Types 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 , testCase "compiled/namespace1" namespaceTest1 , testCase "compiled/namespace2" namespaceTest2 , testCase "compiled/namespace3" namespaceTest3 , testCase "compiled/namespace4" namespaceTest4 , testCase "compiled/namespace5" namespaceTest5 , testCase "compiled/no-ns-splices" noNsSplices , testCase "compiled/ns-nested" nsNestedUnused , testCase "compiled/nsbind" nsBindTest , testCase "compiled/nsbinderr" nsBindErrorTest , testCase "compiled/nscall" nsCallTest , testCase "compiled/nscallerr" nsCallErrTest , testCase "compiled/nsbindstack" nsBindStackTest , testCase "compiled/doctype" doctypeTest , testCase "compiled/exceptions" exceptionsTest , testCase "compiled/defer" deferTest ] simpleCompiledTest :: IO () simpleCompiledTest = do res <- runWithStateSplice "templates" H.assertEqual "compiled state splice" expected res where expected = mappend doctype "\n\n\n3\n\n" peopleTest :: IO () peopleTest = do res <- personListTest "templates" H.assertEqual "people splice" expected res where expected = "\n

    Doe, John: 42 years old

    \n\n

    Smith, Jane: 21 years old

    \n\n" templateHC :: HeistConfig IO templateHC = HeistConfig sc "" False where sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu")) & scTemplateLocations .~ [loadTemplates "templates"] genericTest :: String -> ByteString -> ByteString -> IO () genericTest nm template expected = do res <- runExceptT $ do hs <- ExceptT $ initHeist templateHC runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs template b <- lift $ fst runner return $ toByteString b H.assertEqual nm (Right expected) res doctypeTest :: IO () doctypeTest = genericTest "doctype test" "rss" expected where expected = encodeUtf8 "http://www.devalot.com/\n" namespaceTest1 :: IO () namespaceTest1 = do res <- runExceptT $ do hs <- ExceptT $ initHeist templateHC runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace test 1" (Right expected) res where expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n" namespaceTest2 :: IO () namespaceTest2 = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace test 2" (Right expected) res where expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n" namespaceTest3 :: IO () namespaceTest3 = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace test 3" (Right expected) res where expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n" namespaceTest4 :: IO () namespaceTest4 = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace test 4" (Right expected) res where expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n" namespaceTest5 :: IO () namespaceTest5 = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" & hcCompiledSplices .~ mempty & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res ------------------------------------------------------------------------------ -- | The templates-no-ns directory should have no tags beginning with h: so -- this test will throw an error. noNsSplices :: IO () noNsSplices = do res <- runExceptT $ do hs <- ExceptT $ initHeist hc runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "test" b <- lift $ fst runner return $ toByteString b H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res where hc = HeistConfig sc "h" True sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu")) & scTemplateLocations .~ [loadTemplates "templates-no-ns"] ------------------------------------------------------------------------------ -- | Test that no namespace splice message works correctly when there are no -- top level splices used nsNestedUnused :: IO () nsNestedUnused = do res <- runExceptT $ do hs <- ExceptT $ initHeist hc runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "test" b <- lift $ fst runner return $ toByteString b H.assertEqual "ns nested unused warn test" (Right "
    aeou
    \n") res where hc = HeistConfig sc "h" False sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou") & scTemplateLocations .~ [loadTemplates "templates-ns-nested"] nsBindTemplateHC :: String -> HeistConfig IO nsBindTemplateHC dir = HeistConfig sc "h" False where sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ nsBindTestSplices & scTemplateLocations .~ [loadTemplates dir] nsBindTestSplices :: Splices (Splice IO) nsBindTestSplices = do "call" ## do tpl <- withSplices (callTemplate "_call") nsBindSubSplices (return ()) return $ yieldRuntime $ codeGen tpl "main" ## nsBindSubImpl (return ()) "main2" ## nsBindSubImpl (return ()) nsBindSubImpl :: RuntimeSplice IO b -> Splice IO nsBindSubImpl _ = do tpl <- withSplices runChildren nsBindSubSplices (return ()) return $ yieldRuntime $ codeGen tpl nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO) nsBindSubSplices = do "sub" ## pureSplice . textSplice $ const "asdf" "recurse" ## nsBindSubImpl nsBindTest :: IO () nsBindTest = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind") runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "nsbind" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace bind test" (Right expected) res where expected = "Alpha\n\nBeta\nasdf\nGamma\n\n\n" ------------------------------------------------------------------------------ -- | Test splice error reporting. nsBindErrorTest :: IO () nsBindErrorTest = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind") & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "nsbinderror" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ]) res where err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:sub h:recurse h:call h:main2 h:main\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}" err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n ... via templates-nsbind/nsbinderror.tpl: h:recurse\n ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:sub h:recurse h:call h:main2 h:main\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}" err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main2 h:main\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}" ------------------------------------------------------------------------------ -- | Test splice error data structure. nsBindStackTest :: IO () nsBindStackTest = do res <- initHeist (nsBindTemplateHC "templates-nsbind") >>= return . (either Left (Right . _spliceErrors)) H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res where err1 = SpliceError [ ( ["nsbinderror"] , Just "templates-nsbind/nsbinderror.tpl" , "h:main2") ] (Just "templates-nsbind/nsbinderror.tpl") ["h:sub","h:recurse","h:call","h:main2","h:main"] (X.Element "h:invalid3" [] []) "No splice bound for h:invalid3" err2 = SpliceError [ ( ["nsbinderror"] , Just "templates-nsbind/nsbinderror.tpl" , "h:recurse") , ( ["nsbinderror"] , Just "templates-nsbind/nsbinderror.tpl" ,"h:main") ] (Just "templates-nsbind/nsbinderror.tpl") ["h:sub","h:recurse","h:call","h:main2","h:main"] (X.Element "h:invalid2" [] []) "No splice bound for h:invalid2" err3 = SpliceError [] (Just "templates-nsbind/nsbinderror.tpl") ["h:call","h:main2","h:main"] (X.Element "h:invalid1" [] []) "No splice bound for h:invalid1" nsCallTest :: IO () nsCallTest = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall") & hcErrorNotBound .~ True & hcCompiledTemplateFilter .~ nsFilter runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "nscall" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res where nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head nsCallErrTest :: IO () nsCallErrTest = do res <- runExceptT $ do hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall") & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "nscall" b <- lift $ fst runner return $ toByteString b H.assertEqual "namespace call error test" (Left $ Set.fromList [ err1, err2 ]) (first Set.fromList res) where err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main2 h:main\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}" err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main2 h:main\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}" ------------------------------------------------------------------------------ -- | Test exception handling in template load. exceptionsTest :: IO () exceptionsTest = do res <- Control.Exception.catch (runExceptT $ do hs <- ExceptT $ initHeist hc -- The rest needed only for type inference. runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "" _ <- lift $ fst runner throwE ["Unexpected success"]) (\(e :: CompileException) -> return $ Right (show e, head $ exceptionContext e)) H.assertEqual "exceptions" (Right (msg, err)) $ res where msg = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse\n ... via templates-loaderror/_error.tpl: h:adder\n ... via templates-loaderror/test.tpl: h:call2\nBound splices: h:adder h:call2 h:call1\nNode: Element {elementTag = \"h:adder\", elementAttrs = [(\"value\",\"noparse\")], elementChildren = []}" err = SpliceError [ ( ["test"] , Just "templates-loaderror/_error.tpl" , "h:adder"), ( ["test"] , Just "templates-loaderror/test.tpl" ,"h:call2") ] (Just "templates-loaderror/_error.tpl") ["h:adder", "h:call2", "h:call1"] (X.Element "h:adder" [("value", "noparse")] []) "Exception in splice compile: Prelude.read: no parse" hc = HeistConfig sc "h" True sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ splices & scTemplateLocations .~ [loadTemplates "templates-loaderror"] splices = do "call1" ## callTemplate "_ok" "call2" ## callTemplate "_error" "adder" ## do value :: Int <- read . T.unpack . fromJust . X.getAttribute "value" <$> getParamNode return $ yieldPureText $ T.pack $ show $ 1 + value ------------------------------------------------------------------------------ -- | Test for defer functions to see that they correctly save the result of -- a runtime computation. deferTest :: IO () deferTest = do rs <- mapM newIORef $ replicate 5 (0 :: Int) res <- runExceptT $ do hs <- ExceptT $ initHeist $ hc rs runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "test" b <- lift $ fst runner return $ toByteString b vs <- mapM readIORef rs H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res) where msg = "1 2\n1 1\n1 1\n\n1 1\n" hc rs = HeistConfig (sc rs) "h" True sc rs = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ (splices rs) & scTemplateLocations .~ [loadTemplates "templates-defer"] splices [r1, r2, r3, r4, r5] = do "plain" ## subSplice $ addAndReturn r1 "defer" ## deferMap return subSplice $ addAndReturn r2 "maydefer" ## mayDeferMap (return . Just) subSplice $ addAndReturn r3 "maydefer2" ## mayDeferMap (const $ return Nothing) subSplice $ addAndReturn r4 "defermany" ## deferMany subSplice $ addAndReturn' r5 subSplice = withSplices runChildren ("use" ## \n -> return $ yieldRuntimeText $ return . T.pack . show =<< n) addAndReturn r = liftIO $ modifyIORef r (+1) >> readIORef r addAndReturn' r = liftIO $ do modifyIORef r (+1) val <- readIORef r return [val] heist-1.1.0.1/test/suite/Heist/Interpreted/0000755000000000000000000000000013363531400016621 5ustar0000000000000000heist-1.1.0.1/test/suite/Heist/Interpreted/Tests.hs0000644000000000000000000005645713363531400020300 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.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.Map.Syntax import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T 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.Internal.Types import Heist.Interpreted.Internal import Heist.Splices.Apply import Heist.Splices.Ignore import Heist.Splices.Json import Heist.Splices.Markdown import Heist.TestCommon 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/pandoc" pandocTest , testCase "heist/pandoc_div" pandocDivTest , 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 . unlines) _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" 41 $ 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
    \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 pandocTestSplices 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-1.1.0.1/test/templates-bad/0000755000000000000000000000000013363531400014651 5ustar0000000000000000heist-1.1.0.1/test/templates-bad/apply-missing-attr.tpl0000644000000000000000000000003013363531400021127 0ustar0000000000000000 noroot heist-1.1.0.1/test/templates-bad/apply-template-not-found.tpl0000644000000000000000000000007313363531400022237 0ustar0000000000000000 This template is missing heist-1.1.0.1/test/templates-bad/bind-infinite-loop.tpl0000644000000000000000000000006013363531400021054 0ustar0000000000000000

    line

     heist-1.1.0.1/test/templates-bad/bind-missing-attr.tpl0000644000000000000000000000004013363531400020717 0ustar0000000000000000

    line

     heist-1.1.0.1/docs/0000755000000000000000000000000013363531400012100 5ustar0000000000000000heist-1.1.0.1/docs/templates.md0000644000000000000000000002267613363531400014435 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-1.1.0.1/docs/Makefile0000644000000000000000000000031513363531400013537 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-1.1.0.1/docs/templates.css0000644000000000000000000000113713363531400014612 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-1.1.0.1/extra/0000755000000000000000000000000013363531400012273 5ustar0000000000000000heist-1.1.0.1/extra/logo.gif0000644000000000000000000000113713363531400013724 0ustar0000000000000000GIF89aö` J‡"Kˆ#M‰%NŠ(P‹1W1X3Z‘6\“?d˜4e¤=i£9i¦:j§ 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-1.1.0.1/examples/0000755000000000000000000000000013363531400012766 5ustar0000000000000000heist-1.1.0.1/examples/test01.tpl0000644000000000000000000000011313363531400014622 0ustar0000000000000000bar heist-1.1.0.1/examples/test02.tpl0000644000000000000000000000016313363531400014630 0ustar0000000000000000*** This is a test of the emergency broadcasting system. heist-1.1.0.1/examples/ex01/0000755000000000000000000000000013363531400013543 5ustar0000000000000000heist-1.1.0.1/examples/ex01/nav.tpl0000644000000000000000000000016713363531400015054 0ustar0000000000000000 heist-1.1.0.1/examples/ex01/home.tpl0000644000000000000000000000025713363531400015220 0ustar0000000000000000 Home Page

    Home Page

    Welcome to our home page.

    heist-1.1.0.1/examples/ex03/0000755000000000000000000000000013363531400013545 5ustar0000000000000000heist-1.1.0.1/examples/ex03/home.tpl0000644000000000000000000000026213363531400015216 0ustar0000000000000000

    XYZ Inc.

    Home Page

    Welcome to XYZ Inc

         heist-1.1.0.1/examples/ex03/default.tpl0000644000000000000000000000036313363531400015714 0ustar0000000000000000 Home Page
    heist-1.1.0.1/examples/ex02/0000755000000000000000000000000013363531400013544 5ustar0000000000000000heist-1.1.0.1/examples/ex02/home.tpl0000644000000000000000000000013213363531400015211 0ustar0000000000000000

    Home Page

    Welcome to XYZ Inc

     heist-1.1.0.1/examples/ex02/default.tpl0000644000000000000000000000037613363531400015717 0ustar0000000000000000 Home Page
    heist-1.1.0.1/src/0000755000000000000000000000000013363531400011737 5ustar0000000000000000heist-1.1.0.1/src/Heist.hs0000644000000000000000000003066113363531400013355 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-| This module defines the core data types used by Heist. In practice you will also want to import one or both of "Heist.Compiled" or "Heist.Interpreted" to get functions needed for writing splices. The Heist template system allows you to build custom HTML and XML based markup languages. With Heist you can define your own domain-specific tags implemented with Haskell and use them in your templates. -} module Heist ( -- * Primary Heist initialization functions loadTemplates , reloadTemplates , addTemplatePathPrefix , initHeist , initHeistWithCacheTag , defaultInterpretedSplices , defaultLoadTimeSplices , emptyHeistConfig -- * Core Heist data types , SpliceConfig , HeistConfig , TemplateRepo , TemplateLocation , Template , TPath , MIMEType , DocumentFile(..) , AttrSplice , RuntimeSplice , Chunk , HeistState , SpliceError(..) , CompileException(..) , HeistT -- * Lenses (can be used with lens or lens-family) , scInterpretedSplices , scLoadTimeSplices , scCompiledSplices , scAttributeSplices , scTemplateLocations , scCompiledTemplateFilter , hcSpliceConfig , hcNamespace , hcErrorNotBound , hcInterpretedSplices , hcLoadTimeSplices , hcCompiledSplices , hcAttributeSplices , hcTemplateLocations , hcCompiledTemplateFilter -- * HeistT functions , templateNames , compiledTemplateNames , hasTemplate , spliceNames , compiledSpliceNames , evalHeistT , getParamNode , getContext , getTemplateFilePath , localParamNode , getsHS , getHS , putHS , modifyHS , restoreHS , localHS , getDoc , getXMLDoc , tellSpliceError , spliceErrorText , orError , Splices ) where ------------------------------------------------------------------------------ import Control.Exception.Lifted import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B import Data.Either import qualified Data.Foldable as F import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import qualified Data.HeterogeneousEnvironment as HE import Data.Map.Syntax #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif import Data.Text (Text) import qualified Data.Text as T import System.Directory.Tree import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import qualified Heist.Compiled.Internal as C import qualified Heist.Interpreted.Internal as I import Heist.Splices import Heist.Internal.Types ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | The built-in set of splices that you should use in compiled splice mode. -- This list includes everything from 'defaultInterpretedSplices' plus a -- splice for the content tag that errors out when it sees any instance of the -- old content tag, which has now been moved to two separate tags called -- apply-content and bind-content. defaultLoadTimeSplices :: MonadIO m => Splices (I.Splice m) defaultLoadTimeSplices = do -- To be removed in later versions defaultInterpretedSplices "content" #! deprecatedContentCheck ------------------------------------------------------------------------------ -- | 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 scLoadTimeSplices list in your SpliceConfig. -- 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 ------------------------------------------------------------------------------ -- | An empty HeistConfig that uses the \"h\" namespace with error checking -- turned on. emptyHeistConfig :: HeistConfig m emptyHeistConfig = HeistConfig mempty "h" True allErrors :: [Either String (TPath, v)] -> Either [String] (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 -> IO (Either [String] TemplateRepo) loadTemplates dir = do d <- readDirectoryWith (loadTemplate dir) dir #if MIN_VERSION_directory_tree(0,11,0) return $ allErrors $ F.fold (dirTree d) #else return $ allErrors $ F.fold (free d) #endif ------------------------------------------------------------------------------ -- | Reloads all the templates an an existing TemplateRepo. reloadTemplates :: TemplateRepo -> IO (Either [String] TemplateRepo) reloadTemplates repo = do tlist <- mapM loadOrKeep $ Map.toList repo return $ 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 "" [] False 0 ------------------------------------------------------------------------------ -- | 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 -> IO (Either [String] (HeistState n)) initHeist hc = do keyGen <- HE.newKeyGen repos <- sequence $ _scTemplateLocations $ _hcSpliceConfig hc case sequence repos of Left es -> return $ Left es Right rs -> initHeist' keyGen hc (Map.unions rs) ------------------------------------------------------------------------------ mkSplicePrefix :: Text -> Text mkSplicePrefix ns | T.null ns = "" | otherwise = ns `mappend` ":" ------------------------------------------------------------------------------ initHeist' :: Monad n => HE.KeyGen -> HeistConfig n -> TemplateRepo -> IO (Either [String] (HeistState n)) initHeist' keyGen (HeistConfig sc ns enn) repo = do let empty = emptyHS keyGen let (SpliceConfig i lt c a _ f) = sc etmap <- preproc keyGen lt repo ns let prefix = mkSplicePrefix ns let eis = runHashMap $ mapK (prefix<>) i ecs = runHashMap $ mapK (prefix<>) c eas = runHashMap $ mapK (prefix<>) a let hs1 = do tmap <- etmap is <- eis cs <- ecs as <- eas return $ empty { _spliceMap = is , _templateMap = tmap , _compiledSpliceMap = cs , _attrSpliceMap = as , _splicePrefix = prefix , _errorNotBound = enn } either (return . Left) (C.compileTemplates f) hs1 ------------------------------------------------------------------------------ -- | Runs preprocess on a TemplateRepo and returns the modified templates. preproc :: HE.KeyGen -> Splices (I.Splice IO) -> TemplateRepo -> Text -> IO (Either [String] TemplateRepo) preproc keyGen splices templates ns = do let esm = runHashMap splices case esm of Left errs -> return $ Left errs Right sm -> do let hs = (emptyHS keyGen) { _spliceMap = sm , _templateMap = templates , _preprocessingMode = True , _splicePrefix = mkSplicePrefix ns } let eval a = evalHeistT a (X.TextNode "") hs tPairs <- mapM (eval . preprocess) $ Map.toList templates let bad = lefts tPairs return $ 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 die = error $ "Preprocess failed because the template `" ++ BC.unpack tname ++ "` was not found in the template repository." !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 ------------------------------------------------------------------------------ -- | 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 -> IO (Either [String] (HeistState n, CacheTagState)) initHeistWithCacheTag (HeistConfig sc ns enn) = do (ss, cts) <- liftIO mkCacheTag let tag = "cache" keyGen <- HE.newKeyGen erepos <- sequence $ _scTemplateLocations sc case sequence erepos of Left es -> return $ Left es Right repos -> do -- 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. eRawWithCache <- preproc keyGen (tag ## ss) (Map.unions repos) ns case eRawWithCache of Left es -> return $ Left es Right rawWithCache -> do let sc' = SpliceConfig (tag #! cacheImpl cts) mempty (tag #! cacheImplCompiled cts) mempty mempty (const True) let hc = HeistConfig (mappend sc sc') ns enn hs <- initHeist' keyGen hc rawWithCache return $ fmap (,cts) hs heist-1.1.0.1/src/Heist/0000755000000000000000000000000013363531400013013 5ustar0000000000000000heist-1.1.0.1/src/Heist/Common.hs0000644000000000000000000003475013363531400014610 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Heist.Common where ------------------------------------------------------------------------------ import Control.Applicative (Alternative (..)) import Control.Exception (SomeException) import qualified Control.Exception.Lifted as C import Control.Monad (liftM, mplus) 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 (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.List (isSuffixOf) import Data.Map.Syntax import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Heist.Internal.Types.HeistState import System.FilePath (pathSeparator) import qualified Text.XmlHtml as X #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) import Data.Monoid (Monoid (..)) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ runHashMap :: Splices s -> Either [String] (HashMap T.Text s) runHashMap ms = case runMapSyntax Map.lookup Map.insert ms of Left keys -> Left $ map (T.unpack . mkMsg) keys Right hm -> Right hm where mkMsg k = "You tried to bind "<>k<>" more than once!" ------------------------------------------------------------------------------ runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v runMapNoErrors = either (const mempty) id . runMapSyntax' (\_ new _ -> Just new) Map.lookup Map.insert applySpliceMap :: HeistState n -> (HeistState n -> HashMap Text v) -> MapSyntaxM Text v a -> HashMap Text v applySpliceMap hs f = (flip Map.union (f hs)) . runMapNoErrors . mapK (mappend pre) where pre = _splicePrefix hs ------------------------------------------------------------------------------ -- | 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 do fullMsg <- heistErrMsg (T.pack msg) error $ T.unpack fullMsg else silent ------------------------------------------------------------------------------ -- | Prepends the location of the template currently being processed to an -- error message. heistErrMsg :: Monad m => Text -> HeistT n m Text heistErrMsg msg = do tf <- getsHS _curTemplateFile return $ (maybe "" ((`mappend` ": ") . T.pack) tf) `mappend` msg ------------------------------------------------------------------------------ -- | Adds an error message to the list of splice processing errors. tellSpliceError :: Monad m => Text -> HeistT n m () tellSpliceError msg = do hs <- getHS node <- getParamNode let spliceError = SpliceError { spliceHistory = _splicePath hs , spliceTemplateFile = _curTemplateFile hs , visibleSplices = Map.keys $ _compiledSpliceMap hs , contextNode = node , spliceMsg = msg } modifyHS (\hs' -> hs { _spliceErrors = spliceError : _spliceErrors hs' }) ------------------------------------------------------------------------------ -- | Function for showing a TPath. showTPath :: TPath -> String showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName ------------------------------------------------------------------------------ -- | Convert a TPath into a ByteString path. 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" enc X.ISO_8859_1 = "iso-8859-1" ------------------------------------------------------------------------------ -- | 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 = applySpliceMap hs _attrSpliceMap ss } ------------------------------------------------------------------------------ -- | 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-1.1.0.1/src/Heist/Interpreted.hs0000644000000000000000000000434713363531400015644 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 , renderTemplateToDoc , renderWithArgs ) where import Heist.Interpreted.Internal import Heist.Common (mapSplices, bindAttributeSplices) heist-1.1.0.1/src/Heist/Compiled.hs0000644000000000000000000000325013363531400015103 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 , xmlNodeSplice , htmlNodeSplice , pureSplice , deferMany , defer , deferMap , mayDeferMap , bindLater , withSplices , manyWithSplices , manyWith , 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-1.1.0.1/src/Heist/TemplateDirectory.hs0000644000000000000000000000700213363531400017006 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.Monad import Control.Monad.Trans import Heist import Heist.Internal.Types 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 -- namespaced tag. -> IO (Either [String] (TemplateDirectory n)) newTemplateDirectory dir hc = do let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates dir] } let hc' = hc { _hcSpliceConfig = sc } epair <- initHeistWithCacheTag hc' case epair of Left es -> return $ Left es Right (hs,cts) -> do tsMVar <- liftIO $ newMVar hs ctsMVar <- liftIO $ newMVar cts return $ Right $ 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 <- 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 let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates p] } ehs <- initHeistWithCacheTag (hc { _hcSpliceConfig = sc }) 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: " :: String) heist-1.1.0.1/src/Heist/Splices.hs0000644000000000000000000000513113363531400014751 0ustar0000000000000000{-# LANGUAGE CPP #-} module Heist.Splices ( ifISplice , ifCSplice , ifElseISplice , ifElseCSplice , 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 #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) #endif 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.Internal.Types.HeistState import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ -- | Implements an if\/then\/else conditional splice. It splits its children -- around the \ element to get the markup to be used for the two cases. ifElseISplice :: Monad m => Bool -> I.Splice m ifElseISplice cond = getParamNode >>= (rewrite . X.childNodes) where rewrite nodes = let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes in I.runNodeList $ if cond then ns else (drop 1 ns') ------------------------------------------------------------------------------ -- | Implements an if\/then\/else conditional splice. It splits its children -- around the \ element to get the markup to be used for the two cases. ifElseCSplice :: Monad m => Bool -> C.Splice m ifElseCSplice cond = getParamNode >>= (rewrite . X.childNodes) where rewrite nodes = let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes in C.runNodeList $ if cond then ns else (drop 1 ns') heist-1.1.0.1/src/Heist/Internal/0000755000000000000000000000000013363531400014567 5ustar0000000000000000heist-1.1.0.1/src/Heist/Internal/Types.hs0000644000000000000000000002402413363531400016231 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-| Internal types and accessors. There are no guarantees that heist will preserve backwards compatibility for symbols in this module. If you use them, no complaining when your code breaks. -} module Heist.Internal.Types ( module Heist.Internal.Types.HeistState , module Heist.Internal.Types ) where ------------------------------------------------------------------------------ import Data.HashMap.Strict (HashMap) import Data.Text (Text) #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif ------------------------------------------------------------------------------ import qualified Heist.Compiled.Internal as C import qualified Heist.Interpreted.Internal as I import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ type TemplateRepo = HashMap TPath DocumentFile ------------------------------------------------------------------------------ -- | An IO action for getting a template repo from this location. By not just -- using a directory path here, we support templates loaded from a database, -- retrieved from the network, or anything else you can think of. type TemplateLocation = IO (Either [String] TemplateRepo) ------------------------------------------------------------------------------ -- | My lens creation function to avoid a dependency on lens. lens :: Functor f => (t1 -> t) -> (t1 -> a -> b) -> (t -> f a) -> t1 -> f b lens sa sbt afb s = sbt s <$> afb (sa s) ------------------------------------------------------------------------------ -- | The splices and templates Heist will use. To bind a splice simply -- include it in the appropriate place here. data SpliceConfig m = SpliceConfig { _scInterpretedSplices :: Splices (I.Splice m) -- ^ Interpreted splices are the splices that Heist has always had. -- They return a list of nodes and are processed at runtime. , _scLoadTimeSplices :: Splices (I.Splice IO) -- ^ Load time splices are like interpreted splices because they -- return a list of nodes. But they are like compiled splices because -- they are processed once at load time. All of Heist's built-in -- splices should be used as load time splices. , _scCompiledSplices :: Splices (C.Splice m) -- ^ Compiled splices return a DList of Chunks and are processed at -- load time to generate a runtime monad action that will be used to -- render the template. , _scAttributeSplices :: Splices (AttrSplice m) -- ^ Attribute splices are bound to attribute names and return a list -- of attributes. , _scTemplateLocations :: [TemplateLocation] -- ^ A list of all the locations that Heist should get its templates -- from. , _scCompiledTemplateFilter :: TPath -> Bool -- ^ Predicate function to control which templates to compile. Using -- templates filtered out with this is still possible via -- callTemplate. } ------------------------------------------------------------------------------ -- | Lens for interpreted splices -- :: Simple Lens (SpliceConfig m) (Splices (I.Splice m)) scInterpretedSplices :: Functor f => (Splices (I.Splice m) -> f (Splices (I.Splice m))) -> SpliceConfig m -> f (SpliceConfig m) scInterpretedSplices = lens _scInterpretedSplices setter where setter sc v = sc { _scInterpretedSplices = v } ------------------------------------------------------------------------------ -- | Lens for load time splices -- :: Simple Lens (SpliceConfig m) (Splices (I.Splice IO)) scLoadTimeSplices :: Functor f => (Splices (I.Splice IO) -> f (Splices (I.Splice IO))) -> SpliceConfig m -> f (SpliceConfig m) scLoadTimeSplices = lens _scLoadTimeSplices setter where setter sc v = sc { _scLoadTimeSplices = v } ------------------------------------------------------------------------------ -- | Lens for complied splices -- :: Simple Lens (SpliceConfig m) (Splices (C.Splice m)) scCompiledSplices :: Functor f => (Splices (C.Splice m) -> f (Splices (C.Splice m))) -> SpliceConfig m -> f (SpliceConfig m) scCompiledSplices = lens _scCompiledSplices setter where setter sc v = sc { _scCompiledSplices = v } ------------------------------------------------------------------------------ -- | Lens for attribute splices -- :: Simple Lens (SpliceConfig m) (Splices (AttrSplice m)) scAttributeSplices :: Functor f => (Splices (AttrSplice m) -> f (Splices (AttrSplice m))) -> SpliceConfig m -> f (SpliceConfig m) scAttributeSplices = lens _scAttributeSplices setter where setter sc v = sc { _scAttributeSplices = v } ------------------------------------------------------------------------------ -- | Lens for template locations -- :: Simple Lens (SpliceConfig m) [TemplateLocation] scTemplateLocations :: Functor f => ([TemplateLocation] -> f [TemplateLocation]) -> SpliceConfig m -> f (SpliceConfig m) scTemplateLocations = lens _scTemplateLocations setter where setter sc v = sc { _scTemplateLocations = v } ------------------------------------------------------------------------------ -- | Lens for compiled template filter -- :: Simple Lens (SpliceConfig m) (TBool -> Bool) scCompiledTemplateFilter :: Functor f => ((TPath -> Bool) -> f (TPath -> Bool)) -> SpliceConfig m -> f (SpliceConfig m) scCompiledTemplateFilter = lens _scCompiledTemplateFilter setter where setter sc v = sc { _scCompiledTemplateFilter = v } instance Semigroup (SpliceConfig m) where SpliceConfig a1 b1 c1 d1 e1 f1 <> SpliceConfig a2 b2 c2 d2 e2 f2 = SpliceConfig (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (\x -> f1 x && f2 x) instance Monoid (SpliceConfig m) where mempty = SpliceConfig mempty mempty mempty mempty mempty (const True) #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif data HeistConfig m = HeistConfig { _hcSpliceConfig :: SpliceConfig m -- ^ Splices and templates , _hcNamespace :: Text -- ^ A namespace to use for all tags that are bound to splices. Use -- empty string for no namespace. , _hcErrorNotBound :: Bool -- ^ Whether to throw an error when a tag wih the heist namespace does -- not correspond to a bound splice. When not using a namespace, this -- flag is ignored. } ------------------------------------------------------------------------------ -- | Lens for the SpliceConfig -- :: Simple Lens (HeistConfig m) (SpliceConfig m) hcSpliceConfig :: Functor f => ((SpliceConfig m) -> f (SpliceConfig m)) -> HeistConfig m -> f (HeistConfig m) hcSpliceConfig = lens _hcSpliceConfig setter where setter hc v = hc { _hcSpliceConfig = v } ------------------------------------------------------------------------------ -- | Lens for the namespace -- :: Simple Lens (HeistConfig m) Text hcNamespace :: Functor f => (Text -> f Text) -> HeistConfig m -> f (HeistConfig m) hcNamespace = lens _hcNamespace setter where setter hc v = hc { _hcNamespace = v } ------------------------------------------------------------------------------ -- | Lens for the namespace error flag -- :: Simple Lens (HeistConfig m) Bool hcErrorNotBound :: Functor f => (Bool -> f Bool) -> HeistConfig m -> f (HeistConfig m) hcErrorNotBound = lens _hcErrorNotBound setter where setter hc v = hc { _hcErrorNotBound = v } ------------------------------------------------------------------------------ -- | Lens for interpreted splices -- :: Simple Lens (HeistConfig m) (Splices (I.Splice m)) hcInterpretedSplices :: Functor f => (Splices (I.Splice m) -> f (Splices (I.Splice m))) -> HeistConfig m -> f (HeistConfig m) hcInterpretedSplices = hcSpliceConfig . scInterpretedSplices ------------------------------------------------------------------------------ -- | Lens for load time splices -- :: Simple Lens (HeistConfig m) (Splices (I.Splice IO)) hcLoadTimeSplices :: Functor f => (Splices (I.Splice IO) -> f (Splices (I.Splice IO))) -> HeistConfig m -> f (HeistConfig m) hcLoadTimeSplices = hcSpliceConfig . scLoadTimeSplices ------------------------------------------------------------------------------ -- | Lens for compiled splices -- :: Simple Lens (HeistConfig m) (Splices (C.Splice m)) hcCompiledSplices :: Functor f => (Splices (C.Splice m) -> f (Splices (C.Splice m))) -> HeistConfig m -> f (HeistConfig m) hcCompiledSplices = hcSpliceConfig . scCompiledSplices ------------------------------------------------------------------------------ -- | Lens for attribute splices -- :: Simple Lens (HeistConfig m) (Splices (AttrSplice m)) hcAttributeSplices :: Functor f => (Splices (AttrSplice m) -> f (Splices (AttrSplice m))) -> HeistConfig m -> f (HeistConfig m) hcAttributeSplices = hcSpliceConfig . scAttributeSplices ------------------------------------------------------------------------------ -- | Lens for template locations -- :: Simple Lens (HeistConfig m) [TemplateLocation] hcTemplateLocations :: Functor f => ([TemplateLocation] -> f [TemplateLocation]) -> HeistConfig m -> f (HeistConfig m) hcTemplateLocations = hcSpliceConfig . scTemplateLocations ------------------------------------------------------------------------------ -- | Lens for compiled template filter -- :: Simple Lens (SpliceConfig m) (TBool -> Bool) hcCompiledTemplateFilter :: Functor f => ((TPath -> Bool) -> f (TPath -> Bool)) -> HeistConfig m -> f (HeistConfig m) hcCompiledTemplateFilter = hcSpliceConfig . scCompiledTemplateFilter heist-1.1.0.1/src/Heist/Internal/Types/0000755000000000000000000000000013363531400015673 5ustar0000000000000000heist-1.1.0.1/src/Heist/Internal/Types/HeistState.hs0000644000000000000000000005734613363531400020323 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# 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.Internal.Types.HeistState where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder (Builder) import Control.Applicative (Alternative (..)) import Control.Arrow (first) import Control.Exception (Exception) import Control.Monad (MonadPlus (..), ap) import Control.Monad.Base import Control.Monad.Cont (MonadCont (..)) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except (MonadError (..)) #else import Control.Monad.Error (MonadError (..)) #endif #if MIN_VERSION_base(4,9,0) import qualified Control.Monad.Fail as Fail #endif import Control.Monad.Fix (MonadFix (..)) import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State.Strict (MonadState (..), StateT) import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control import Data.ByteString.Char8 (ByteString) import Data.DList (DList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import Data.HeterogeneousEnvironment (HeterogeneousEnvironment) import qualified Data.HeterogeneousEnvironment as HE import Data.Map.Syntax #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) #if MIN_VERSION_base (4,7,0) import Data.Typeable (Typeable) #else import Data.Typeable (TyCon, Typeable(..), Typeable1(..), mkTyCon, mkTyConApp) #endif #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) import Data.Monoid (Monoid(..)) #endif import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | Convenient type alies for splices. type Splices s = MapSyntax Text s ------------------------------------------------------------------------------ -- | 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, Show #if MIN_VERSION_base(4,7,0) , Typeable #endif ) ------------------------------------------------------------------------------ -- | 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 #if MIN_VERSION_base(4,7,0) , Typeable #endif ) ------------------------------------------------------------------------------ instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where a <> b = do !x <- a !y <- b return $! x <> y #if !MIN_VERSION_base(4,11,0) instance (Monad m, Semigroup a, Monoid a) => Monoid (RuntimeSplice m a) where #else instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where #endif mempty = return mempty #if !MIN_VERSION_base(4,11,0) mappend = (<>) #endif ------------------------------------------------------------------------------ -- | 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 #if MIN_VERSION_base(4,7,0) deriving Typeable #endif 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)] ------------------------------------------------------------------------------ -- | Detailed information about a splice error. data SpliceError = SpliceError { spliceHistory :: [(TPath, Maybe FilePath, Text)] , spliceTemplateFile :: Maybe FilePath , visibleSplices :: [Text] , contextNode :: X.Node , spliceMsg :: Text } deriving ( Show, Eq ) ------------------------------------------------------------------------------ -- | Transform a SpliceError record to a Text message. spliceErrorText :: SpliceError -> Text spliceErrorText (SpliceError hist tf splices node msg) = (maybe "" ((`mappend` ": ") . T.pack) tf) `T.append` msg `T.append` foldr (\(_, tf', tag) -> (("\n ... via " `T.append` (maybe "" ((`mappend` ": ") . T.pack) tf') `T.append` tag) `T.append`)) T.empty hist `T.append` if null splices then T.empty else "\nBound splices:" `T.append` foldl (\x y -> x `T.append` " " `T.append` y) T.empty splices `T.append` (T.pack $ "\nNode: " ++ (show node)) ------------------------------------------------------------------------------ -- | Exception type for splice compile errors. Wraps the original -- exception and provides context. --data (Exception e) => CompileException e = CompileException data CompileException = forall e . Exception e => CompileException { originalException :: e -- The list of splice errors. The head of it has the context -- related to the exception. , exceptionContext :: [SpliceError] } deriving ( Typeable ) instance Show CompileException where show (CompileException e []) = "Heist load exception (unknown context): " ++ (show e) show (CompileException _ (c:_)) = (T.unpack $ spliceErrorText c) instance Exception CompileException ------------------------------------------------------------------------------ -- | 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 -- | Stack of the splices used. , _splicePath :: [(TPath, Maybe FilePath, Text)] -- | 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 -- | A prefix for all splices (namespace ++ ":"). , _splicePrefix :: Text -- | List of errors encountered during splice processing. , _spliceErrors :: [SpliceError] -- | Whether to throw an error when a tag wih the heist namespace does not -- correspond to a bound splice. When not using a namespace, this flag is -- ignored. , _errorNotBound :: Bool , _numNamespacedTags :: Int #if MIN_VERSION_base(4,7,0) } deriving (Typeable) #else } #endif #if !MIN_VERSION_base(4,7,0) -- 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 ())] #endif ------------------------------------------------------------------------------ -- | 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) #if MIN_VERSION_base(4,7,0) } deriving Typeable #else } #endif ------------------------------------------------------------------------------ -- | 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 #if !MIN_VERSION_base(4,7,0) ------------------------------------------------------------------------------ -- | The Typeable instance is here so Heist can be dynamically executed with -- Hint. templateStateTyCon :: TyCon templateStateTyCon = mkTyCon "Heist.HeistState" {-# NOINLINE templateStateTyCon #-} #endif ------------------------------------------------------------------------------ -- | 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 (>>=) #-} #if MIN_VERSION_base(4,9,0) ------------------------------------------------------------------------------ -- | MonadFail instance instance Fail.MonadFail m => Fail.MonadFail (HeistT n m) where fail = lift . Fail.fail #endif ------------------------------------------------------------------------------ -- | 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) instance MonadBase b m => MonadBase b (HeistT n m) where liftBase = lift . liftBase #if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl (HeistT n) where type StT (HeistT n) a = (a, HeistState n) liftWith f = HeistT $ \n s -> do res <- f $ \(HeistT g) -> g n s return (res, s) restoreT k = HeistT $ \_ _ -> k {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where type StM (HeistT n m) a = ComposeSt (HeistT n) m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} #else instance MonadTransControl (HeistT n) where newtype StT (HeistT n) a = StHeistT {unStHeistT :: (a, HeistState n)} liftWith f = HeistT $ \n s -> do res <- f $ \(HeistT g) -> liftM StHeistT $ g n s return (res, s) restoreT k = HeistT $ \_ _ -> liftM unStHeistT k {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where newtype StM (HeistT n m) a = StMHeist {unStMHeist :: ComposeSt (HeistT n) m a} liftBaseWith = defaultLiftBaseWith StMHeist restoreM = defaultRestoreM unStMHeist {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} #endif ------------------------------------------------------------------------------ -- | 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 #if !MIN_VERSION_base(4,7,0) ------------------------------------------------------------------------------ -- | 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 ())] #endif ------------------------------------------------------------------------------ -- 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 $ curry return {-# 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 and splice errors. 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 , _numNamespacedTags = _numNamespacedTags cur , _spliceErrors = _spliceErrors 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) }) ------------------------------------------------------------------------------ -- | Increments the namespaced tag count incNamespacedTags :: Monad m => HeistT n m () incNamespacedTags = modifyHS (\st -> st { _numNamespacedTags = _numNamespacedTags st + 1 }) ------------------------------------------------------------------------------ -- | 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-1.1.0.1/src/Heist/Compiled/0000755000000000000000000000000013363531400014547 5ustar0000000000000000heist-1.1.0.1/src/Heist/Compiled/LowLevel.hs0000644000000000000000000000100213363531400016625 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-1.1.0.1/src/Heist/Compiled/Internal.hs0000644000000000000000000007404513363531400016671 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# 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.Exception 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.Map.Syntax 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 Text.Printf import qualified Text.XmlHtml as X import qualified Text.XmlHtml.HTML.Meta as X ------------------------------------------------------------------------------ #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable) #endif import qualified Data.Foldable as Foldable ------------------------------------------------------------------------------ import Heist.Common import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- | 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 us 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 DocumentFile with the appropriate template context set. runDocumentFile :: Monad n => TPath -> DocumentFile -> Splice n runDocumentFile tpath df = do let markup = case dfDoc df of X.XmlDocument _ _ _ -> Xml X.HtmlDocument _ _ _ -> Html modifyHS (\hs -> hs { _curMarkup = markup }) let inDoctype = X.docType $ dfDoc df addDoctype $ maybeToList inDoctype 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 => TPath -> DocumentFile -> HeistT n IO [Chunk n] compileTemplate tpath df = do !chunks <- runDocumentFile tpath df return $! consolidate chunks ------------------------------------------------------------------------------ compileTemplates :: Monad n => (TPath -> Bool) -> HeistState n -> IO (Either [String] (HeistState n)) compileTemplates f hs = do (tmap, hs') <- runHeistT (compileTemplates' f) (X.TextNode "") hs let pre = _splicePrefix hs' let canError = _errorNotBound hs' let errs = _spliceErrors hs' let nsErr = if not (T.null pre) && (_numNamespacedTags hs' == 0) then Left [noNamespaceSplicesMsg $ T.unpack pre] else Right () return $ if canError then case errs of [] -> nsErr >> (Right $! hs { _compiledTemplateMap = tmap }) es -> Left $ either (++) (const id) nsErr $ map (T.unpack . spliceErrorText) es else nsErr >> (Right $! hs { _compiledTemplateMap = tmap , _spliceErrors = errs }) ------------------------------------------------------------------------------ noNamespaceSplicesMsg :: String -> String noNamespaceSplicesMsg pre = unwords [ printf "You are using a namespace of '%s', but you don't have any" ns , printf "tags starting with '%s'. If you have not defined any" pre , "splices, then change your namespace to the empty string to get rid" , "of this message." ] where ns = reverse $ drop 1 $ reverse pre ------------------------------------------------------------------------------ compileTemplates' :: Monad n => (TPath -> Bool) -> HeistT n IO (H.HashMap TPath ([Chunk n], MIMEType)) compileTemplates' f = do hs <- getHS let tpathDocfiles :: [(TPath, DocumentFile)] tpathDocfiles = filter (f . fst) (H.toList $ _templateMap hs) foldM runOne H.empty tpathDocfiles where runOne tmap (tpath, df) = do modifyHS (\hs -> hs { _doctypes = []}) !mHtml <- compileTemplate 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, codeGen 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 = do pre <- getsHS _splicePrefix res <- getsHS (H.lookup nm . _compiledSpliceMap) if isNothing res && T.isPrefixOf pre nm && not (T.null pre) then do tellSpliceError $ "No splice bound for " `mappend` nm return Nothing else return res ------------------------------------------------------------------------------ -- | 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 hs <- getHS let pre = _splicePrefix hs let hasPrefix = (T.isPrefixOf pre `fmap` X.tagName node) == Just True when (not (T.null pre) && hasPrefix) incNamespacedTags hs' <- getHS -- Plain rethrows for CompileException to avoid multiple annotations. (res, hs'') <- liftIO $ catches (compileIO hs') [ Handler (\(ex :: CompileException) -> throwIO ex) , Handler (\(ex :: SomeException) -> handleError ex hs')] putHS hs'' return res where localSplicePath = localHS (\hs -> hs {_splicePath = (_curContext hs, _curTemplateFile hs, X.elementTag node): (_splicePath hs)}) compileIO hs = runHeistT compile node hs compile = do isStatic <- subtreeIsStatic node dl <- compile' isStatic liftIO $ evaluate $ DL.fromList $! consolidate dl compile' True = do markup <- getsHS _curMarkup return $! yieldPure $! renderFragment markup [parseAttrs node] compile' False = localSplicePath $ compileNode node handleError ex hs = do errs <- evalHeistT (do localSplicePath $ tellSpliceError $ T.pack $ "Exception in splice compile: " ++ show ex getsHS _spliceErrors) node hs throwIO $ CompileException ex errs 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) = do msplice <- lookupSplice nm fromMaybe compileStaticElement msplice 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) } where n' = _splicePrefix ts `mappend` n ------------------------------------------------------------------------------ -- | 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 hs = hs { _compiledSpliceMap = applySpliceMap hs _compiledSpliceMap 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. -- -- Note that template names should not include the .tpl extension: -- -- @renderTemplate hs "index"@ 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 -> Splice n callTemplate nm = do hs <- getHS maybe (error err) call $ lookupTemplate nm hs _templateMap where err = "callTemplate: "++(T.unpack $ T.decodeUtf8 nm)++(" does not exist") call (df,_) = localHS (\hs' -> hs' {_curTemplateFile = dfFile df}) $ runNodeList $ X.docContent $ dfDoc df 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 -- --------------- ------------------------------------------------------------------------------ -- | This is the same as htmlNodeSplice. nodeSplice :: (a -> [X.Node]) -> a -> Builder nodeSplice f = X.renderHtmlFragment X.UTF8 . f {-# DEPRECATED nodeSplice "Use xmlNodeSplice or htmlNodeSplice, will be removed in Heist 1.1" #-} ------------------------------------------------------------------------------ -- | Converts a pure XML Node splice function to a pure Builder splice -- function. xmlNodeSplice :: (a -> [X.Node]) -> a -> Builder xmlNodeSplice f = X.renderXmlFragment X.UTF8 . f ------------------------------------------------------------------------------ -- | Converts a pure HTML Node splice function to a pure Builder splice -- function. htmlNodeSplice :: (a -> [X.Node]) -> a -> Builder htmlNodeSplice 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' mempty splice where splices' = mapV ($runtimeAction) splices ------------------------------------------------------------------------------ {-# INLINE foldMapM #-} foldMapM :: (Monad f, Monoid m, Foldable list) => (a -> f m) -> list a -> f m foldMapM f = Foldable.foldlM (\xs x -> xs `seq` liftM (xs <>) (f x)) mempty ------------------------------------------------------------------------------ -- | Like withSplices, but evaluates the splice repeatedly for each element in -- a list generated at runtime. manyWithSplices :: (Foldable f, Monad n) => Splice n -> Splices (RuntimeSplice n a -> Splice n) -> RuntimeSplice n (f a) -> Splice n manyWithSplices splice splices runtimeAction = manyWith splice splices mempty runtimeAction ------------------------------------------------------------------------------ -- | More powerful version of manyWithSplices that lets you also define -- attribute splices. manyWith :: (Foldable f, Monad n) => Splice n -> Splices (RuntimeSplice n a -> Splice n) -> Splices (RuntimeSplice n a -> AttrSplice n) -> RuntimeSplice n (f a) -> Splice n manyWith splice splices attrSplices runtimeAction = do p <- newEmptyPromise let splices' = mapV ($ getPromise p) splices let attrSplices' = mapV ($ getPromise p) attrSplices chunks <- withLocalSplices splices' attrSplices' splice return $ yieldRuntime $ do items <- runtimeAction foldMapM (\item -> putPromise p item >> codeGen chunks) items ------------------------------------------------------------------------------ -- | 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 :: (Foldable f, Monad n) => (RuntimeSplice n a -> Splice n) -> RuntimeSplice n (f a) -> Splice n deferMany f getItems = do promise <- newEmptyPromise chunks <- f $ getPromise promise return $ yieldRuntime $ do items <- getItems foldMapM (\item -> putPromise promise item >> codeGen chunks) items ------------------------------------------------------------------------------ -- | Saves the results of a runtime computation in a 'Promise' so they don't -- get recalculated if used more than once. -- -- Note that this is just a specialized version of function application ($) -- done for the side effect in runtime splice. defer :: Monad n => (RuntimeSplice n a -> Splice n) -> RuntimeSplice n a -> Splice n defer pf n = do p2 <- newEmptyPromise let action = yieldRuntimeEffect $ putPromise p2 =<< n res <- pf $ getPromise p2 return $ action `mappend` res ------------------------------------------------------------------------------ -- | A version of defer which applies a function on the runtime value. deferMap :: Monad n => (a -> RuntimeSplice n b) -> (RuntimeSplice n b -> Splice n) -> RuntimeSplice n a -> Splice n deferMap f pf n = defer pf $ f =<< n ------------------------------------------------------------------------------ -- | 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. mayDeferMap :: Monad n => (a -> RuntimeSplice n (Maybe b)) -> (RuntimeSplice n b -> Splice n) -> RuntimeSplice n a -> Splice n mayDeferMap f pf n = deferMany pf $ f =<< n ------------------------------------------------------------------------------ -- | 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-1.1.0.1/src/Heist/Interpreted/0000755000000000000000000000000013363531400015300 5ustar0000000000000000heist-1.1.0.1/src/Heist/Interpreted/Internal.hs0000644000000000000000000004114113363531400017411 0ustar0000000000000000{-# 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 qualified Data.HashMap.Strict as Map import qualified Data.HeterogeneousEnvironment as HE import Data.Map.Syntax import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ 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 = hs { _spliceMap = applySpliceMap hs _spliceMap 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 . mapV 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 = bindSplices (mapV textSplice 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 $ mapV 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. -- -- Note that template names should not include the .tpl extension: -- -- @renderTemplate hs "index"@ 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) renderTemplateToDoc :: Monad n => HeistState n -> ByteString -> n (Maybe X.Document) renderTemplateToDoc hs name = evalHeistT (evalWithDoctypes name) (X.TextNode "") hs heist-1.1.0.1/src/Heist/Splices/0000755000000000000000000000000013363531400014415 5ustar0000000000000000heist-1.1.0.1/src/Heist/Splices/Markdown.hs0000644000000000000000000002534613363531400016545 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-| 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. You can add custom pandoc splice with 'pandocSplice'. It is not limited to markdown input, and can process anything pandoc can. For example you can create a page with generated table of contents, using heist template as pandoc template. > > > <pageTitle/> > >
    > > And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and applies "_wrap" template. > > > $title$ > $toc$ > $body$ > Bind splice pandoc splice. Set it to not wrap in div, or it will break html from _wrap.tpl > splices = "docmarkdown" ## pandocSplice opts > where > opts = setPandocArgs ["-S", "--no-wrap", "--toc" > , "--standalone" > , "--template", "_pandoc.tpl" > , "--html5"] > $ setPandocWrapDiv Nothing > $ defaultPandocOptions > And then use it to render your markdown file > > > > > > > > > > -} module Heist.Splices.Markdown ( -- * Exceptions PandocMissingException , MarkdownException , NoMarkdownFileException -- * Markdown Splice , markdownTag , markdownSplice -- * Generic pandoc splice , pandocSplice -- ** Pandoc Options , PandocOptions , defaultPandocOptions , setPandocExecutable , setPandocArgs , setPandocBaseDir , setPandocWrapDiv -- ** Lens for 'PandocOptions' , pandocExecutable , pandocArgs , pandocBaseDir , pandocWrapDiv ) where ------------------------------------------------------------------------------ import Control.Concurrent import Control.Exception.Lifted import Control.Monad import Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import System.Directory import System.Exit import System.FilePath.Posix import System.IO import System.Process import Text.XmlHtml #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif ------------------------------------------------------------------------------ import Heist.Common import Heist.Internal.Types.HeistState import Heist.Interpreted.Internal data PandocMissingException = PandocMissingException deriving (Typeable) instance Show PandocMissingException where show PandocMissingException = "Cannot find the \"pandoc\" executable. If you have Haskell, then install it with \"cabal install\". Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html. Then make sure it is in 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 -------------------------------------------------------------------------------- data PandocOptions = PandocOptions { _pandocExecutable :: FilePath , _pandocArgs :: [String] -- ^ Arguments to pandoc , _pandocBaseDir :: Maybe FilePath -- ^ Base directory for input files -- defaults to template path , _pandocWrapDiv :: Maybe Text -- ^ Wrap content in div with class } deriving (Eq, Ord, Show) -- | Default options defaultPandocOptions :: PandocOptions defaultPandocOptions = PandocOptions "pandoc" [] Nothing (Just "markdown") -- | Name of pandoc executable setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions setPandocExecutable e opt = opt { _pandocExecutable = e } -- | Arguments passed to pandoc setPandocArgs :: [String] -> PandocOptions -> PandocOptions setPandocArgs args opt = opt { _pandocArgs = args } -- | Base directory for input files, defaults to current template dir setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions setPandocBaseDir bd opt = opt { _pandocBaseDir = bd } -- | Wrap pandoc output in div with class. Appends node attributes to -- div and appends class to ones specified on node. setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions setPandocWrapDiv wd opt = opt { _pandocWrapDiv = wd } pandocExecutable :: Functor f => (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions pandocExecutable f po = (\e -> po { _pandocExecutable = e}) <$> f (_pandocExecutable po) pandocArgs :: Functor f => ([String] -> f [String]) -> PandocOptions -> f PandocOptions pandocArgs f po = (\a -> po { _pandocArgs = a}) <$> f (_pandocArgs po) pandocBaseDir :: Functor f => (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions pandocBaseDir f po = (\b -> po {_pandocBaseDir = b }) <$> f (_pandocBaseDir po) pandocWrapDiv :: Functor f => (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions pandocWrapDiv f po = (\w -> po {_pandocWrapDiv = w}) <$> f (_pandocWrapDiv po) ------------------------------------------------------------------------------ -- | Default name for the markdown splice. markdownTag :: Text markdownTag = "markdown" ------------------------------------------------------------------------------ -- | Default markdown splice with executable "pandoc" markdownSplice :: MonadIO m => Splice m markdownSplice= pandocSplice defaultPandocOptions -- | Implementation of the markdown splice. pandocSplice :: MonadIO m => PandocOptions -> Splice m pandocSplice PandocOptions{..} = do templateDir <- liftM (fmap takeDirectory) getTemplateFilePath pdMD <- liftIO $ findExecutable _pandocExecutable pandocExe <- case pdMD of Nothing -> liftIO $ throwIO PandocMissingException Just pd -> return pd let withDir tp = fromMaybe tp _pandocBaseDir pandocFile f tp = pandocWith pandocExe _pandocArgs (withDir tp) f tree <- getParamNode (source,markup) <- liftIO $ case getAttribute "file" tree of Just f -> do m <- maybe (liftIO $ throwIO NoMarkdownFileException ) (pandocFile (T.unpack f)) templateDir return (T.unpack f,m) Nothing -> do m <- pandocWithBS pandocExe _pandocArgs $ T.encodeUtf8 $ nodeText tree return ("inline_splice",m) let ee = parseHTML source markup nodeAttrs = case tree of Element _ a _ -> a _ -> [] nodeClass = lookup "class" nodeAttrs attrs = filter (\(name, _) -> name /= "class" && name /= "file") nodeAttrs case ee of Left e -> throw $ MarkdownException $ BC.pack ("Error parsing markdown output: " ++ e) Right d -> return $ wrapResult nodeClass attrs (docContent d) where wrapResult nodeClass attrs body = case _pandocWrapDiv of Nothing -> body Just cls -> let finalAttrs = ("class", appendClass nodeClass cls):attrs in [Element "div" finalAttrs body] appendClass Nothing cls = cls appendClass (Just orig) cls = T.concat [orig, " ", cls] pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString pandocWith path args templateDir inputFile = do (ex, sout, serr) <- readProcessWithExitCode' path args' "" when (isFail ex) $ throw $ MarkdownException serr return sout where isFail ExitSuccess = False isFail _ = True args' = args ++ [templateDir inputFile ] pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString pandocWithBS pandocPath args s = do -- using the crummy string functions for convenience here (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s when (isFail ex) $ throw $ MarkdownException serr return sout where isFail ExitSuccess = False isFail _ = True -- 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-1.1.0.1/src/Heist/Splices/Ignore.hs0000644000000000000000000000122313363531400016172 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-1.1.0.1/src/Heist/Splices/Bind.hs0000644000000000000000000000247013363531400015630 0ustar0000000000000000module Heist.Splices.Bind where ------------------------------------------------------------------------------ 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.Internal.Types.HeistState -- | 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 :: Monad 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-1.1.0.1/src/Heist/Splices/Apply.hs0000644000000000000000000000747113363531400016047 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Heist.Splices.Apply where ------------------------------------------------------------------------------ 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.Internal.Types.HeistState ------------------------------------------------------------------------------ -- | 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!" :: String 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 :: Monad 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 :: Monad 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-1.1.0.1/src/Heist/Splices/Json.hs0000644000000000000000000002054713363531400015672 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Heist.Splices.Json ( bindJson ) where ------------------------------------------------------------------------------ import Control.Monad.Reader import Data.Aeson import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as Map import Data.Map.Syntax 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 Text.Blaze.Html5 ((!)) import qualified Text.Blaze.Html5 as B import Text.Blaze.Renderer.XmlHtml import Text.XmlHtml ------------------------------------------------------------------------------ import Heist.Interpreted.Internal import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ ------------ -- 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 :: ToJSON a => a -> 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 (Array arr) = tryReadIndex >>= \i -> arr V.!? i findIn _ = Nothing tryReadIndex = fmap fst . listToMaybe . reads . T.unpack $ x ------------------------------------------------------------------------------ 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 :: forall n. (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 :: 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 :: Value -> (JsonMonad n n [Node]) -> Splice n 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 :: 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 bindings >> newBindings heist-1.1.0.1/src/Heist/Splices/BindStrict.hs0000644000000000000000000000231313363531400017015 0ustar0000000000000000module Heist.Splices.BindStrict where ------------------------------------------------------------------------------ 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.Internal.Types.HeistState -- | Default name for the bind splice. bindStrictTag :: Text bindStrictTag = "bindStrict" ------------------------------------------------------------------------------ -- | Implementation of the bind splice. bindStrictImpl :: Monad 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-1.1.0.1/src/Heist/Splices/Cache.hs0000644000000000000000000001642113363531400015760 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 System.Random import Text.XmlHtml #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif ------------------------------------------------------------------------------ import qualified Heist.Compiled.Internal as C import Heist.Interpreted.Internal import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ 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-1.1.0.1/src/Heist/Splices/Html.hs0000644000000000000000000000324713363531400015663 0ustar0000000000000000module Heist.Splices.Html where ------------------------------------------------------------------------------ import Data.Maybe import Data.Text (Text) import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Interpreted.Internal import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ -- | 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-1.1.0.1/src/Data/0000755000000000000000000000000013363531400012610 5ustar0000000000000000heist-1.1.0.1/src/Data/HeterogeneousEnvironment.hs0000644000000000000000000000550713363531400020214 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